VBA loop through workbooks and sheet names and copy to existing sheet names in master

Question

I have many workbooks that have different sheet names (they are always the same although not every file has every sheet) and a master file that has all possible sheets names. I am trying to loop over all workbooks in the folder and:

Open each file, loop over all sheets and copy all bold cells within a specific range from each sheet
Paste this ranges underneath each other in the appropriate (= equally named) sheet in a master spreadsheet

I have a code that works for the first sheet, but I am not sure how to loop over the sheet names and match them with the master sheet, in particular since the sheets can be in different order and the workbooks don't always include all sheets.

 Sub LoopThroughFiles6()

    Dim firstEmptyRow As Long
    Dim SourceFolder As String, StrFile As String, filenameCriteria As String
    Dim attachmentWorkBook As Workbook, attachmentWorkSheet As Worksheet
    Dim copyRng As Range
    Dim cell As Range
    Dim tempRange As Range
    
    SourceFolder = "C:\Users\x0514\Desktop\test\"
    StrFile = Dir(SourceFolder & "*.xlsx")
    
    Do While Len(StrFile) > 0
        Debug.Print StrFile
    
        Set attachmentWorkBook = Workbooks.Open(Filename:=SourceFolder & StrFile)
        
        For Each attachmentWorkSheet In attachmentWorkBook.Worksheets
            With ThisWorkbook.Worksheets(attachmentWorkSheet.Name)
                '#firstEmptyRow returns the first empty row in column B
                firstEmptyRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 2
                
                '#paste file name to Column A
                .Range("A" & firstEmptyRow) = StrFile
                
                '#paste data in column B
                Set copyRng = attachmentWorkSheet.Range("A1:CA4")
                
                '# Select only bold cells in this range
    For Each cell In copyRng
        If cell.Font.Bold = True Then
            If tempRange Is Nothing Then
                Set tempRange = cell
            Else
   
                Set tempRange = attachmentWorkBook.Application.Union(tempRange, cell) 
'# code throws an error here, I suspect I did not correctly specify the open workbook
            End If
        End If
    Next cell
     
    If Not tempRange Is Nothing Then
        tempRange.Select
    End If
    
    
                .Range("B" & firstEmptyRow).Resize(tempRange.Rows.Count, tempRange.Columns.Count).Value = tempRange.Value
            End With
        Next
        
        attachmentWorkBook.Close SaveChanges:=False
        StrFile = Dir
    Loop
  
End Sub

GSerg GSerg · Accepted Answer · 2020-09-16T10:28:15

Sub LoopThroughFiles()

    Dim firstEmptyRow As Long
    Dim SourceFolder As String, StrFile As String, filenameCriteria As String
    Dim attachmentWorkBook As Workbook, attachmentWorkSheet As Worksheet
    Dim copyRng As Range
    Dim header As Range
    
    SourceFolder = "C:\Users\x0514\Desktop\test\"
    StrFile = Dir(SourceFolder & "*.xlsx")
    
    Do While Len(StrFile) > 0
        Debug.Print StrFile
    
        Set attachmentWorkBook = Workbooks.Open(Filename:=SourceFolder & StrFile)
        
        For Each attachmentWorkSheet In attachmentWorkBook.Worksheets
            With ThisWorkbook.Worksheets(attachmentWorkSheet.Name)
                '#firsEmptyRow returns the first empty row in column B
                firstEmptyRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
                
                '#paste file name to Column A
                .Range("A" & firstEmptyRow) = StrFile
                
                '#paste data in column B
                Set copyRng = attachmentWorkSheet.Range("A1:CA4")
                .Range("B" & firstEmptyRow).Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
            End With
        Next
        
        attachmentWorkBook.Close SaveChanges:=False
        StrFile = Dir
    Loop
  
End Sub

VBA loop through workbooks and sheet names and copy to existing sheet names in master

1 Answers