Excel VBA。从多个工作簿中复制数据并粘贴到同一个工作表中的一个工作簿中

Question

我有一个代码，它使用户能够打开工作簿并将工作表的内容自动复制到另一个工作簿工作表。如何选择一个包含多个工作簿的文件夹并从每个工作簿复制数据并粘贴到同一张工作簿的同一张工作表中。

基本上在找到第一个文件后，它应该复制内容并粘贴，然后复制另一个文件粘贴到其他工作表的内容之后。下面是我的代码。

Sub uploadFile()

Application.ScreenUpdating = False  ' disable screen updating

Dim sPath As String   ' Path names in getopenfilename
sPath = "C:\Users\Desktop\November"   

' find the network path
If SetUNCPath(sPath) <> 0 Then

    ' message to show to pick a file
    MsgBox "Select the text file '"
    FileToOpen = Application.GetOpenFilename(Title:="Please choose a file to import")

    ' if the user doens't select a file the sub should terminate and do nothing
    If FileToOpen = False Then
        MsgBox "No file specified.", vbExclamation, "Alert!!!"
            Exit Sub
    Else
      ' Clear contents in Template
      If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False 'Remove Filters if exists
      LastRow = ActiveSheet.Range("A1").Offset(ActiveSheet.Rows.Count - 1, 0).End(xlUp).Row
      If LastRow > 1 Then Worksheets("Data").Range("A2:AL" & LastRow).Clear

      ' open work book and assign splits
      Workbooks.OpenText Filename:= _
      FileToOpen, _
      Origin:=437, StartRow:=1, DataType:=xlFixedWidth, _
      FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(38, 1), Array(45, 1), Array(54, 1), _
      Array(84, 1), Array(91, 1), Array(99, 1), Array(100, 1), Array(106, 1), Array(114, 1), Array(118, 1), Array(121, 1), _
      Array(133, 1), Array(148, 1), Array(151, 1), Array(160, 1), Array(182, 1), _
      Array(190, 1), Array(198, 1), Array(218, 1), Array(219, 1), Array(228, 1), _
      Array(248, 1), Array(260, 1), Array(271, 1), Array(278, 1), Array(289, 1), Array(300, 1), Array(311, 1), Array(315, 1), _
      Array(326, 1), Array(333, 1), Array(340, 1), Array(347, 1), Array(351, 1), Array(357, 1), Array(410, 1)), TrailingMinusNumbers:=True_

      ' splits the path
      SplitPath = Split(FileToOpen, Application.PathSeparator)
      Filename = SplitPath(UBound(SplitPath))

      ' Copy contents from file
      If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False 'Remove Filters if exists
      LastRow = ActiveSheet.Range("A1").Offset(ActiveSheet.Rows.Count - 1, 0).End(xlUp).Row
      Range("A1:AF" & LastRow).Copy

      ' error if file name changes
      Windows("TEMPLATE BPLG.xlsb").Activate
      Sheets("Data").Select 'Select the sheet
      Range("A2").PasteSpecial Paste:=xlPasteValues

      ' Extract the file name of the source file
      SplitPath = Split(FileToOpen, Application.PathSeparator)
      Filename = SplitPath(UBound(SplitPath))
      FileDT = FileDateTime(FileToOpen)

      ' Close the Source file
      Windows(Filename).Activate
      Application.DisplayAlerts = False
      ActiveWindow.Close
      Application.DisplayAlerts = True
      Range("A1").Select

      ' Formulas
      [AG2] = "=Z2/100"
      [AH2] = "=AA2/100"
      [AI2] = "=AB2/100"
      [AJ2] = "=AC2/100"
      [AK2] = "=AD2/100"
      [AL2] = "=AG2-AH2-AI2-AJ2-AK2"

      ' Copy down
      [AG2:AL2].Copy
      LastRow = ActiveSheet.Range("A1").Offset(ActiveSheet.Rows.Count - 1, 0).End(xlUp).Row
      Range("AG2:AL" & LastRow).Select
      ActiveSheet.Paste

    End If
End If

' Reset
Sheets("HOME").Select   ' Go to Home
Range("A1").Select      ' go to A1
Application.ScreenUpdating = True 'enable screen updating

' message to display the process is completed
MsgBox "Step complete"

End Sub

Answer 1

 Dim sPath As String   ' Path names in getopenfilename
 sPath = "C:\Users\Desktop\November"   
 dim s as string
 dim wb as workbook
' find the network path
 If SetUNCPath(sPath) <> 0 Then
  s = dir(spath & "\*.xls?")  'find first spreadsheet in folder
  Do
     'open file for processing
     set wb = workbooks.opentext(filename:=spath & "\" & s,.....etc
      'etc...
     wb.close false 'close without saving
     s = dir() 'find subsequent files
 loop until s = ""


 End If