Копирование ячеек из 2-х или более книг в новую книгу

Question

Я пытаюсь написать код, который копирует клетки C24, C25 и D24, D25 из всех .xls файлы из папки "C:\MyPath\" и я новичок в использовании VBA но я завожусь решение в режиме онлайн и смогло составить код, который объединяет все файлы excel в папке и копирует их в отдельную книгу с каждой книгой, выходящей на каждый лист.

Th код я работал на это

Option Explicit 
Sub CopyWorksheets() 

    Const sPath = "C:\MyPath\" 
    Dim sFile As String 
    Dim wbkSource As Workbook 
    Dim wSource As Worksheet 
    Dim wbkTarget As Workbook 

    On Error GoTo ErrHandler 
    Application.ScreenUpdating = False 

    Set wbkTarget = ActiveWorkbook 
    sFile = Dir(sPath & "*.xls*") 
    Do While Not sFile = "" 
    Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False) 
    For Each wSource In wbkSource.Worksheets 
     With wbkTarget 
     wSource.Copy After:=.Sheets(.Sheets.Count) 
     End With 
    Next 
    wbkSource.Close SaveChanges:=False 
    sFile = Dir 
    Loop 

ExitHandler: 
    Application.ScreenUpdating = True 
    Exit Sub 

ErrHandler: 
    MsgBox Err.Description, vbExclamation 
    Resume ExitHandler 
End Sub 

Могу ли я знать изменения или дополнения в коде выше, чтобы получить мое решение?

Answer 1

Я скопировал ваш код в новую книгу. Я переименовал рабочий лист Лист1 в C24D25 и создал строку заголовка:

 A  B   C  D  E  F 
    1 Workbook Worksheet C24 D24 C25 D25 

В верхней части вашего обычный я добавил дополнительные переменные и константу I Требуется:

Const colTgtWbk As Long = 1 
Const colTgtWsht As Long = 2 
Const colTgtC24 As Long = 3 
Const colTgtC25 As Long = 5 

Dim wshtTarget As Worksheet 
Dim rowTgtCrnt As Long 

Set wshtTarget = ActiveWorkbook.Worksheets("C24D25") 
rowTgtCrnt = 2 

Заменить «C24D25» с вашим именем для рабочий лист, на который собираются значения.

Я изменил определение sPath в папку на моем ноутбуке, содержащую несколько книг.

В верхней части кода я закомментирована:

'On Error GoTo ErrHandler 

и ближе к концу я закомментирована:

'ExitHandler: 
    'Exit Sub 
'ErrHandler: 
    'MsgBox Err.Description, vbExclamation 
    'Resume ExitHandler 

Я никогда не включают в свой собственный обработчик ошибок в процессе разработки, и я никогда не включать один в макросе производства, если я не обнаружил необходимость во время разработки. Процедура обработчика ошибок не является лучшим методом обработки ошибок, которые вы ожидаете и можете проверить. Они должны быть зарезервированы за ошибки, которые вы не можете проверить, например, при попытке открыть файл, для которого у вас может не быть разрешения на чтение.

Вокруг основного блока:

Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False) 
    to 
    wbkSource.Close SaveChanges:=False 

Я добавил, если:

If sFile <> wbkTarget.Name Then 

End If 

Это позволяет избежать попытки вновь открыть книгу, в которой вы собираете данные.

Я удалил:

With wbkTarget 
    wSource.Copy After:=.Sheets(.Sheets.Count) 
End With 

и заменил этот код:

With wshtTarget 
    .Cells(rowTgtCrnt, colTgtWbk).Value = wbkSource.Name 
    .Cells(rowTgtCrnt, colTgtWsht).Value = wSource.Name 
    wSource.Range("C24:D24").Copy Destination:=.Cells(rowTgtCrnt, colTgtC24) 
    wSource.Range("C25:D25").Copy Destination:=.Cells(rowTgtCrnt, colTgtC25) 
    rowTgtCrnt = rowTgtCrnt + 1 
End With 

Это код, который создает строки в рабочий лист C24D25.

В нижней части я добавил:

wshtTarget.Columns.AutoFit 

Это расширяет столбцы для ширины найденных данных.

В результате изменений выше:

Option Explicit 
Sub CopyWorksheets() 

    Const colTgtWbk As Long = 1 
    Const colTgtWsht As Long = 2 
    Const colTgtC24 As Long = 3 
    Const colTgtC25 As Long = 5 

    Dim wshtTarget As Worksheet 
    Dim rowTgtCrnt As Long 

    Set wshtTarget = ActiveWorkbook.Worksheets("C24D25") 
    rowTgtCrnt = 2 

    Const sPath = "C:\DataArea\SOTest\Excel\" 
    Dim sFile As String 
    Dim wbkSource As Workbook 
    Dim wSource As Worksheet 
    Dim wbkTarget As Workbook 

    Application.ScreenUpdating = False 

    Set wbkTarget = ActiveWorkbook 
    sFile = Dir(sPath & "*.xls*") 
    Do While sFile <> "" 

    If sFile <> wbkTarget.Name Then 

     Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False) 
     For Each wSource In wbkSource.Worksheets 

     With wshtTarget 
      .Cells(rowTgtCrnt, colTgtWbk).Value = wbkSource.Name 
      .Cells(rowTgtCrnt, colTgtWsht).Value = wSource.Name 
      wSource.Range("C24:D24").Copy Destination:=.Cells(rowTgtCrnt, colTgtC24) 
      wSource.Range("C25:D25").Copy Destination:=.Cells(rowTgtCrnt, colTgtC25) 
      rowTgtCrnt = rowTgtCrnt + 1 
     End With 

     Next 
     wbkSource.Close SaveChanges:=False 

    End If 

    sFile = Dir 
    Loop 

    wshtTarget.Columns.AutoFit 

    Application.ScreenUpdating = True 

End Sub 

Я надеюсь, что цели изменений, которые я сделал очевидны, задавайте вопросы, если это необходимо.