VBA EXCEL - Import data from several worksheets from file A to several worksheets in file B

Question

I need your help today for a loop.

I have a code that allow me to import informations from worksheet A file A to worksheet A file B. What I would like to add is a loop that will allow me to check every worksheet on the file A and if they match to the worksheets that I have on the file B then I would like to import the same type of data that I imported from my worksheet A file A to worksheet A file B (same format). Each worksheet is equal to a project.

This is the current code without the loop that i would like to add =

   Sub traitementfichierexcel()
Dim CD As Workbook 
Dim OD As Worksheet 
Dim EF As FileDialog 
Dim CS As Workbook 
Dim OS As Worksheet 
Dim TV As Variant 
Dim TL() As Variant 
Dim I As Integer 
Dim K As Integer 
Dim LastRowSource As Long
Dim RowDestination As Integer
RowDestination = 2
Application.ScreenUpdating = False 
Set CD = ThisWorkbook 
Set OD = CD.Worksheets(1) 
OD.Range("B1").CurrentRegion.Offset(1, 0).ClearContents
Set EF = Application.FileDialog(msoFileDialogOpen)
EF.AllowMultiSelect = False 
EF.Show 
If EF.SelectedItems.Count = 0 Then Exit Sub 
'Set CS = Workbooks.Open(EF.SelectedItems(1)) 
Set CS = GetObject(EF.SelectedItems(1))
Set OS = CS.Worksheets(1) 'définit l'onglet source OS


TV = OS.Range("B7").CurrentRegion 'définit le tableau des valeurs TV
LastRowSource = OS.Range("B" & Rows.Count).End(xlUp).row 


  With OS.Range("B8:F" & LastRowSource) 
            .AutoFilter field:=1, Criteria1:="OK"
        
    End With
    
  For Each cl In OS.Range("C8:F" & LastRowSource).SpecialCells(xlCellTypeVisible).EntireRow 'Boucle sur les lignes qui reste visible après le filtre
        OD.Cells(RowDestination, 2) = "OK"
        OD.Cells(RowDestination, 3) = cl.Cells(3)
        OD.Cells(RowDestination, 4) = cl.Cells(4)
        OD.Cells(RowDestination, 5) = cl.Cells(5)
        OD.Cells(RowDestination, 6) = cl.Cells(6)
        RowDestination = RowDestination + 1
    Next cl

If K > 0 Then OD.Range("B2").Resize(K, 3) = Application.Transpose(TL)
 CS.Close SaveChanges:=False
Application.ScreenUpdating = True 

MsgBox "Import terminé !", vbInformation

    Set OD = Nothing: Set OS = Nothing
    Set CD = Nothing
    Set fd = Nothing

End Sub

Can somebody help? What king of loop do i need and what kind of code shloud I add in order to make this work.

Thank you in advance

Lucas

Answer 1

Try the code below. You'll need two For...Next loops. First one goes through all worksheets in CD, second is needed to check if a particular worksheet has a "match" in CS.worksheets (.Name = .Name). If so, start importing data. Inserted comments below with triple quotes, to distinguish them from your own comments.

Sub traitementfichierexcel()
Dim CD As Workbook
Dim OD As Worksheet
Dim EF As FileDialog
Dim CS As Workbook
Dim OS As Worksheet
Dim TV As Variant
Dim TL() As Variant
Dim I As Integer
Dim K As Integer
Dim LastRowSource As Long
Dim RowDestination As Integer
RowDestination = 2
Application.ScreenUpdating = False
Set CD = ThisWorkbook

''' Set OD = CD.Worksheets(1) (set OD within the two loops when match is found)
''' OD.Range("B1").CurrentRegion.Offset(1, 0).ClearContents (add underneath there)

Set EF = Application.FileDialog(msoFileDialogOpen)
EF.AllowMultiSelect = False
EF.Show
If EF.SelectedItems.Count = 0 Then Exit Sub
'Set CS = Workbooks.Open(EF.SelectedItems(1))
Set CS = GetObject(EF.SelectedItems(1))
''' Set OS = CS.Worksheets(1) 'définit l'onglet source OS (set OS within the two loops when match is found)

Dim wsCD As Worksheet, wsCS As Worksheet

''' loop through all sheets in CD
For Each wsCD In CD.Worksheets

    ''' loop through all sheets in CS
    For Each wsCS In CS.Worksheets
    
        ''' if you find sheets with matching names, do stuff
        If wsCD.Name = wsCS.Name Then
        
            Set OD = wsCD ''' i.e. this will be CD.Worksheets(wsCD.Name)
            OD.Range("B1").CurrentRegion.Offset(1, 0).ClearContents
            
            Set OS = wsCS ''' i.e. this will be OS.Worksheets(wsCS.Name)
        
            ''' do all your stuff
            TV = OS.Range("B7").CurrentRegion 'définit le tableau des valeurs TV
            LastRowSource = OS.Range("B" & Rows.Count).End(xlUp).Row
            
            
            With OS.Range("B8:F" & LastRowSource)
                .AutoFilter field:=1, Criteria1:="OK"
            
            End With
                
            For Each cl In OS.Range("C8:F" & LastRowSource).SpecialCells(xlCellTypeVisible).EntireRow 'Boucle sur les lignes qui reste visible après le filtre
                OD.Cells(RowDestination, 2) = "OK"
                OD.Cells(RowDestination, 3) = cl.Cells(3)
                OD.Cells(RowDestination, 4) = cl.Cells(4)
                OD.Cells(RowDestination, 5) = cl.Cells(5)
                OD.Cells(RowDestination, 6) = cl.Cells(6)
                RowDestination = RowDestination + 1
            Next cl
            
            If K > 0 Then OD.Range("B2").Resize(K, 3) = Application.Transpose(TL)
        
        End If
        
    Next wsCS

Next wsCD

''' done, close CS
CS.Close SaveChanges:=False
Application.ScreenUpdating = True

MsgBox "Import terminé !", vbInformation

    Set OD = Nothing: Set OS = Nothing
    Set CD = Nothing
    Set fd = Nothing

End Sub