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

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

1 个答案: