Question

我有一本带有几张标签纸的主工作簿。我正在尝试更新此工作簿中名为949，div和active pl的工作表。

这3个工作表中每一个的数据都将从3个子工作簿中提取，因此分别命名为949.xlsx，div.xlsx和activepl.xlsx。这些工作簿各只有一张。

如何清除除标题行之外的现有数据，然后将每个子工作簿中的所有数据（不考虑标题的第一行）复制到主工作簿中分别命名的工作表中？

我到目前为止拥有的宏：

Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Ensure Workbook has opened before moving on to next line of code
      DoEvents


    'Save and Close Workbook
      wb.Close SaveChanges:=True

    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Answer 1

尝试

Sub LoopAllExcelFilesInFolder()
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog
    Dim vName As Variant, vDB As Variant
    Dim Master As Workbook, Target As Range
    Dim i As Integer

    Set Master = ThisWorkbook

    vName = Array("949", "div", "activepl")
    'Optimize Macro Speed
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual

    'Retrieve Target Folder Path From User
      Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

        With FldrPicker
          .Title = "Select A Target Folder"
          .AllowMultiSelect = False
            If .Show <> -1 Then GoTo NextCode
            myPath = .SelectedItems(1) & "\"
        End With

    'In Case of Cancel
NextCode:
      myPath = myPath
      If myPath = "" Then GoTo ResetSettings

    'Target File Extension (must include wildcard "*")
      myExtension = "*.xls*"

    'Target Path with Ending Extention
      myFile = Dir(myPath & myExtension)

    'Loop through each Excel file in folder
      Do While myFile <> ""
        For i = 0 To 2
            If InStr(myFile, vName(i)) Then


            'Set variable equal to opened workbook
              Set wb = Workbooks.Open(Filename:=myPath & myFile)
                vDB = wb.ActiveSheet.UsedRange.Offset(1)
                Master.Sheets(vName(i)).UsedRange.Offset(1).Clear '<~~ Clear cells except head
                Set Target = Master.Sheets(vName(i)).Range("b" & Rows.Count).End(xlUp)(2) '<~~ column b
                Target.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
            'Ensure Workbook has opened before moving on to next line of code
              DoEvents


            'Save and Close Workbook
              wb.Close SaveChanges:=True

            'Ensure Workbook has closed before moving on to next line of code
              DoEvents
            End If
        Next i
            'Get next file name
              myFile = Dir
      Loop

    'Message Box when tasks are completed
      MsgBox "Task Complete!"

ResetSettings:
      'Reset Macro Optimization Settings
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True

End Sub

您可以通过根据工作表名称指定条件来更改位置。

        If vName(i) = "activepl" Then
            Master.Sheets(vName(i)).UsedRange.Offset(1, 1).Clear '<~~ Clear cells except head
            Set Target = Master.Sheets(vName(i)).Range("b" & Rows.Count).End(xlUp)(2) '<~~ column b
        Else
            Master.Sheets(vName(i)).UsedRange.Offset(1).Clear '<~~ Clear cells except head
            Set Target = Master.Sheets(vName(i)).Range("a" & Rows.Count).End(xlUp)(2) '<~~ column b
        End If

版本

Sub LoopAllExcelFilesInFolder()
    Dim wb As Workbook
    Dim myPath As String
    Dim myFile As String
    Dim myExtension As String
    Dim FldrPicker As FileDialog
    Dim vName As Variant, vDB As Variant
    Dim Master As Workbook, Target As Range
    Dim i As Integer

    Set Master = ThisWorkbook

    vName = Array("949", "div", "activepl")
    'Optimize Macro Speed
      Application.ScreenUpdating = False
      Application.EnableEvents = False
      Application.Calculation = xlCalculationManual

    'Retrieve Target Folder Path From User
      Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

        With FldrPicker
          .Title = "Select A Target Folder"
          .AllowMultiSelect = False
            If .Show <> -1 Then GoTo NextCode
            myPath = .SelectedItems(1) & "\"
        End With

    'In Case of Cancel
NextCode:
      myPath = myPath
      If myPath = "" Then GoTo ResetSettings

    'Target File Extension (must include wildcard "*")
      myExtension = "*.xls*"

    'Target Path with Ending Extention
      myFile = Dir(myPath & myExtension)

    'Loop through each Excel file in folder
      Do While myFile <> ""
        For i = 0 To 2
            If InStr(myFile, vName(i)) Then

            'Set variable equal to opened workbook
              Set wb = Workbooks.Open(Filename:=myPath & myFile)

                vDB = wb.ActiveSheet.UsedRange.Offset(1)

                If vName(i) = "activepl" Then
                    Master.Sheets(vName(i)).UsedRange.Offset(1, 1).Clear '<~~ Clear cells except head
                    Set Target = Master.Sheets(vName(i)).Range("b" & Rows.Count).End(xlUp)(2) '<~~ column b
                Else
                    Master.Sheets(vName(i)).UsedRange.Offset(1).Clear '<~~ Clear cells except head
                    Set Target = Master.Sheets(vName(i)).Range("a" & Rows.Count).End(xlUp)(2) '<~~ column b
                End If
                Target.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
            'Ensure Workbook has opened before moving on to next line of code
              DoEvents


            'Save and Close Workbook
              wb.Close SaveChanges:=True

            'Ensure Workbook has closed before moving on to next line of code
              DoEvents
            End If
        Next i
            'Get next file name
              myFile = Dir
      Loop

    'Message Box when tasks are completed
      MsgBox "Task Complete!"

ResetSettings:
      'Reset Macro Optimization Settings
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True

End Sub

通过其他工作簿中的多个独立工作表更新主工作簿

1 个答案: