Обновление основной рабочей книги с помощью нескольких независимых листов из других рабочих книг

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

Edition

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