VBA遍历工作簿和工作表名称并复制到主控表中的现有工作表名称

Question

我有许多具有不同工作表名称的工作簿（尽管并非每个文件都有每个工作表，但它们始终相同）和一个包含所有可能工作表名称的主文件。我正在尝试遍历文件夹中的所有工作簿，并且：

1. 打开每个文件，遍历所有工作表并从每个工作表复制特定范围内的所有粗体单元格

2. 在主电子表格的相应（= 同名）工作表中将这些范围粘贴到彼此下方

我有一个适用于第一张工作表的代码，但我不确定如何遍历工作表名称并将它们与主工作表匹配，特别是因为工作表可以按不同的顺序排列而工作簿没有始终包括所有工作表。

 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

Answer 1

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