[VBA] [MULTISELECT] Копирование нескольких выбранных файлов в Active Workbook не работает должным образом

Question

Это мой первый пост здесь, поэтому я постараюсь обобщить ситуацию.

Я хотел бы отметить, что мои навыки программирования равны нулю, поэтому я взял кусочки нескольких кодов и попытался понять логику c, стоящую за ним, чтобы создать этот макрос. Будьте добры.

- Цель Кодекса: Копировать и вставить информацию из нескольких выбранных файлов в Активную книгу.

- Шаги:

Шаг 1. Создание рабочего листа в открытом файле

Шаг 2. Размещение заголовков на созданном рабочем листе

Шаг 3. Выбор нескольких файлов для копирования информации из

Шаг 4: Скопируйте содержимое выбранных файлов на рабочий лист, созданный на шаге 1

- Сам код

Dim fnameList, fnameCurFile, headers() As Variant
Dim wks, wksDst, DstSht, wsCopy, wsDest, ws, wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook, wb As Workbook
Dim CopyLastRow, DestLastRow As Long

'Step 1
            Application.DisplayAlerts = False
            On Error Resume Next
            ActiveWorkbook.Sheets("Consolidate_Data").Delete
            Application.DisplayAlerts = False

        With ActiveWorkbook
            Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            DstSht.Name = "Consolidate_Data"
        End With

'Step 2
Application.ScreenUpdating = False

Set wb = ActiveWorkbook
Set ws = ActiveWorkbook.Sheets("Consolidate_Data")

headers() = Array("Superhero", "City", "State", "Country", "Publisher", "Demographics", _
    "Planet", "Flying Abilities", "Vehicle", "Sidekick", "Powers")
For Each ws In wb.Sheets
    With ws
    .Rows(1).Value = "" 'This will clear out row 1
    For i = LBound(headers()) To UBound(headers())
        .Cells(1, 1 + i).Value = headers(i)
    Next i
    .Rows(1).Font.Bold = True
    End With
Next ws

'Step 3
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Selecione os arquivos", MultiSelect:=True)

If (vbBoolean <> VarType(fnameList)) Then

        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0

            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

            Set wbkCurBook = ActiveWorkbook

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
Next
                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
Next

'Step 4

  Set wsCopy = wbkSrcBook.Sheets("Relatório_Ouvidoria_monitoria")
  Set wsDest = Workbooks("Novo(a) Planilha do Microsoft Excel.xlsm").Sheets("Consolidate_Data")

  CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
  DestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row

            For Each wksCurSheet In wbkSrcBook.Sheets
                wbkSrcBook.Sheets("Relatório_Ouvidoria_monitoria").Range("A2:M" & CopyLastRow).Copy _
                wsDest.Range("A" & DestLastRow)
                wbkSrcBook.Close Savechanges:=False
            Next

            MsgBox "Foram consolidados " & countFiles & " arquivos" & vbCrLf & "Foram importadas " & countSheets & " planilhas", Title:="Merge Excel files"

  Else
        MsgBox "Nenhum arquivo selecionado", Title:="Merge Excel files"
End If
End If
End Sub

- Проблема: На шаге 4 (или я так полагаю) макрос копирует информацию только из первого выбранного файла, оставляя другие позади.

Я не знаю, важно ли это: каждый файл я Выбор имеет только один лист с тем же именем. К сожалению, изменить имя рабочего листа не представляется возможным.

Можете ли вы, ребята, помочь мне?

Answer 1

В этой части вашего кода:

For Each fnameCurFile In fnameList
  countFiles = countFiles + 1
  Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
Next

Вы открываете каждую книгу в al oop и устанавливаете для нее wbkSrcBook. К концу l oop все рабочие книги могут быть открыты, но wbkSrcBook теперь установлен только на последнюю рабочую книгу в l oop. Затем позже, в другом l oop, вы (пытаетесь) работать с каждым листом в этом, но затем все равно закрываете после первого листа:

For Each wksCurSheet In wbkSrcBook.Sheets
   wbkSrcBook.Sheets("Relatório_Ouvidoria_monitoria").Range("A2:M" & CopyLastRow).Copy _
   wsDest.Range("A" & DestLastRow)
   wbkSrcBook.Close Savechanges:=False
Next

У вас уже есть все имена книг в массив после использования средства выбора файлов. Вы перебираете этот массив, чтобы открыть каждый, по какой-то причине подсчитываете их, затем работаете только с последней открытой книгой в отдельном l oop.

Вместо этого вы можете попытаться переместить вашу логику копирования / вставки c в тот же l oop, который вы используете для открытия каждой книги. Откройте каждую книгу -> скопируйте ее данные в место назначения, закройте ее, откройте следующую.

(на работе, поэтому у меня нет времени, чтобы перекодировать это, и я бы прокомментировал это, но у меня недостаточно очков, чтобы оставлять комментарии.) Надеюсь, это немного поможет.