Перебор несколько листов в нескольких книгах

Question

My Macro нужно запустить через этот диапазон на листе «AtualizaABS», который содержит данные, необходимые для Macro работа:

1. макросъемки сусла проверьте столбец F в диапазоне, чтобы определить имя листа в текущей книге, где он будет вставлять данные (переменная «Destino» в коде).

2. После этого макрос переходит к открытию новой папки, в которой он будет искать книгу, имя которой соответствует значению в столбце E (переменная «ABSid» в коде).

3. После идентификации книги макрос должен скопировать все ячейки листа, имя которого соответствует значениям в столбце G (переменная «Дадос» в коде), а затем вставить данные из недавно открытой книги в оригинальный (точно в листе, определяемом переменной «Destino» и столбец F).

Код работает для первой строки диапазона, но, когда речь идет цикл по другим критериям в листе «AtualizaABS» и другие книги, чтобы быть открыт, он терпит неудачу (хотя я использовал " Для каждой команды.

Как я могу сделать цикл макросов через строки в моем диапазоне, а затем через книги в папке, определенной кодом?

Sub CopyThenPaste() 

Dim wb1 As Workbook 
Dim wb2 As Workbook 
Dim Sheet As Worksheet 
Dim PasteStart As Range 
On Error GoTo Errorcatch 

'States the number of the last row thtat contains relevant information to the Macro 
ultima_linha = Range("e2", Range("e2").End(xlDown)).Rows.Count 

'Selects the data to be used in the Macro 
Worksheets("AtualizaABS").Activate 
For i = 2 To ultima_linha + 1 
Destino = ActiveSheet.Cells(i, 6).Value 
Dados = ActiveSheet.Cells(i, 7).Value 
ABSid = ActiveSheet.Cells(i, 5).Value 

'Selects all of the cells of the worksheet that is going to be updated 
    Set wb1 = ActiveWorkbook 
    For Each Sheet In wb1.Worksheets 
    Set PasteStart = Worksheets(Destino).[A1] 
    Sheets(Destino).Select 
    Cells.Select 

'Asks the user what is the folder where VBA should look for the Workbook with the new information 
    With Application.FileDialog(msoFileDialogFolderPicker) 
    .Title = "Por favor escolha uma pasta" 
    .AllowMultiSelect = False 
    If .Show = -1 Then Pasta = .SelectedItems(1) 
    End With 


'Opens the new workbook, copies and then pastes the data in the current Workbook 
    For Each wb2 In Workbooks 
    Set wb2 = Workbooks.Open(Filename:=Pasta & "\" & ABSid & ".xls") 
    wb2.Sheets(Dados).Select 
    Cells.Select 
    Selection.Copy 
    wb1.Worksheets(Destino).Paste Destination:=PasteStart 

    Application.CutCopyMode = False 
    wb2.Close 


    Next 

    Next 


Next 


Exit Sub 
Errorcatch: 
MsgBox Err.Description 


End Sub 

Спасибо за внимание.

Answer 1

Вам не нужно перебрать все объекты Workbook, или через все объекты Worksheet, так что ваш код может быть упрощена:

Sub CopyThenPaste() 

    Dim wb1 As Workbook 
    Set wb1 = ActiveWorkbook 

    Dim wsAtualizaABS As Worksheet 
    Set wsAtualizaABS = wb1.Worksheets("AtualizaABS") 

    Dim wb2 As Workbook 

    Dim Destino As String 
    Dim Dados As String 
    Dim ABSid As String 
    Dim Pasta As String 

    On Error GoTo Errorcatch 

    'States the number of the last row that contains relevant information to the Macro 
    ultima_linha = wsAtualizaABS.Range("e2").End(xlDown).Row 

    For i = 2 To ultima_linha 
     Destino = wsAtualizaABS.Cells(i, 6).Value 
     Dados = wsAtualizaABS.Cells(i, 7).Value 
     ABSid = wsAtualizaABS.Cells(i, 5).Value 

'******************** 
'**** This block of code can probably be executed outside the loop, 
'**** unless the path to each workbook is different 
     'Asks the user what is the folder where VBA should look for the Workbook with the new information 
     With Application.FileDialog(msoFileDialogFolderPicker) 
      .Title = "Por favor escolha uma pasta" 
      .AllowMultiSelect = False 
      If .Show = -1 Then Pasta = .SelectedItems(1) 
     End With 
'******************** 

     'Opens the new workbook, copies and then pastes the data in the current Workbook 
     Set wb2 = Workbooks.Open(Filename:=Pasta & "\" & ABSid & ".xls") 
     wb2.Sheets(Dados).Cells.Copy Destination:=wb1.Worksheets(Destino).Range("A1") 
     wb2.Close 

    Next 

    Exit Sub 

Errorcatch: 
    MsgBox Err.Description 

End Sub