Sub DAORU()


MyNow = Now
'On Error GoTo 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim CurFile As String
Dim DestWB As Workbook
Dim ws As Object 'Allows for diffrent sheet types
MyoldFile = ThisWorkbook.Name
MyFile = Application.GetOpenFilename("(*.*),*.xls)", , "Please Select Folder")
If MyFile = False Then Exit Sub

DirLoc = CurDir(MyFile) & "\" 'MyPath 'location of files

'Set DestWB = Workbooks.Add(xlWorksheet)
'MyNewFile = ActiveWorkbook.Name
'Workbooks(MyNewFile).Activate
CurFile = Dir(DirLoc & "*.xls")

  m = 0
  n = 0
Do While CurFile <> vbNullString

    Dim origwb As Workbook
    Set origwb = Workbooks.Open(Filename:=DirLoc & CurFile, UpdateLinks:=0, ReadOnly:=True)
    MynewFile = ActiveWorkbook.Name


    Workbooks(MyoldFile).Worksheets("往来数据采集").Range("b3:m51").Offset(n, 0).Value = Workbooks(MynewFile).Worksheets("2关联往来余额").Range("A24:L72").Value

    origwb.Close savechanges:=False '不保存关闭工作簿
    CurFile = Dir 'dir函数

m = m + 4
n = n + 49
Loop
'sjhz1 '调用程序



Application.DisplayAlerts = True
Application.ScreenUpdating = True
'DestWB.Close savechanges:=False '不保存关闭工作簿
'Set DestWB = Nothing

MsgBox Format(Now - MyNow, "hh:mm:ss")
0:
'Sheet1.Activate


End Sub