答:
Sub CopyToFile()
Dim Wb As Workbook, sFile As String
Dim Rng As Range, C As Range
Dim FirstAddress As String
Dim Sht As Worksheet
sPath = ThisWorkbook.Path & "\测试文件夹\"
sFile = Dir(sPath & "*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Rng = Sheets("名字1").Range("C1:D4")
Do While sFile <> ""
Set Wb = Workbooks.Open(sPath & sFile)
For Each Sht In Wb.Worksheets
With Sht
Set C = .UsedRange.Find(what:="总计", lookat:=xlWhole)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
Rng.Copy C.Offset(0, 1)
Set C = .UsedRange.FindNext(C)
Loop While Not C Is Nothing And C.Address <> FirstAddress
End If
End With
Next Sht
Wb.Close savechanges:=True
sFile = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub