VBA 从多个工作簿中具有相似名称的不同工作表中提取值

如何解决VBA 从多个工作簿中具有相似名称的不同工作表中提取值

我想使用 VBA 在我目前正在处理的这个工作簿（存储工作簿）中创建一个汇总表，以查看多个报告（超过 100 个）并提取某些值。

每个报告包含 10 多个工作表，但我只对从标题为 Day1、Day2、Day3 等的工作表中复制单元格 A4:A5 感兴趣

我发现使用下面的代码取得了成功，并为每个第 1 天、第 2 天、第 3 天等创建了一个模块...

Sub Day1_values()

Dim basebook As Workbook
Dim mybook As Workbook
Dim ws As Worksheet

Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Cnum As Integer
Dim cell As Range
Dim foldername As String
Dim getpath As String
Dim myFilePath As String

SaveDriveDir = CurDir
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
        MyPath = .SelectedItems(1)
    End If
   End With
   

If MyPath <> "" Then

ChDrive MyPath
ChDir MyPath

FNames = Dir("*.xlsm")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook

rnum = 2

Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)

' This will add the workbook name in column A
basebook.Worksheets(1).Cells(rnum,"A").Value = mybook.Name
basebook.Worksheets(1).Cells(rnum,"B").Value = mybook.Path

Cnum = 3 'begin pasting the values in column 3

For Each cell In mybook.Worksheets("Day1").Range("A4:A5")
    basebook.Worksheets(1).Cells(rnum,Cnum).Value = cell.Value
    Cnum = Cnum + 1
    Next cell
    
    mybook.Close False
    rnum = rnum + 1
    FNames = Dir()
    Loop

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True

End If
End Sub

问题是：每个工作簿包含不同的天数。例如报表 1 有 day1 - day5 而报表 2 只有 day1 - day2

所以当我为 Day3 创建一个模块时上面的代码不起作用，因为它会看到报告 2 没有 Day3 并且代码会因为“下标超出范围”而中断

如果工作表名称包含“Day*”以复制单元格 A4:A5 并将它们粘贴到我的存储工作簿中，那么有谁知道我如何操作代码以对每个工作簿进行说明？

这里有一个类似的帖子：Loop through worksheets with a specific name

他们成功地使用了这个代码来解决他们的问题：

If ws.Name Like "danger" & "*" Then    
     ws.Range("A1").Interior.ColorIndex = 37
End If

我只是不知道如何将它添加到我现有的代码中。非常感谢任何想法或帮助！！谢谢！！！

解决方法

尝试这样的事情：

Sub ImportWorksheetData()

    Dim basebook As Workbook,mybook As Workbook
    Dim ws As Worksheet
    Dim MyPath As String
    Dim rwResults As Range,nm As String,f

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            MyPath = .SelectedItems(1)
        End If
    End With
    If Len(MyPath) = 0 Then Exit Sub 'no folder chosen
    If Right(MyPath,1) <> "\" Then MyPath = MyPath & "\" 'ensure trailing \
    
    Set basebook = ThisWorkbook
    Set rwResults = basebook.Worksheets(1).Rows(2)
    
    f = Dir(MyPath & "*.xlsm")
    Do While Len(f) > 0
        Set mybook = Workbooks.Open(MyPath & f)
        For Each ws In mybook.Worksheets
            'Does the worksheet name match our pattern?
            nm = UCase(Replace(ws.Name," ","")) 'ignore spaces when checking
            If nm Like "DAY#" Or nm Like "DAY##" Then  '# = any digit
                rwResults.Columns("A").Value = f
                rwResults.Columns("B").Value = MyPath
                rwResults.Columns("C").Value = ws.Name
                rwResults.Columns("D").Value = ws.Range("A4").Value
                rwResults.Columns("E").Value = ws.Range("A5").Value
                Set rwResults = rwResults.Offset(1,0) 'move down for next sheet
            End If
        Next ws
        
        mybook.Close False 'no save
        f = Dir()
    Loop
    
End Sub

,

从工作簿收集数据

Option Explicit

Sub CollectData()

    Const sPattern As String = "*.xlsm"
    Const swsPatternLCase As String = "day*"
    Const sAddressesList As String = "A4,A5" ' add more
    
    Const dID As Variant = 1 ' or e.g. "Sheet1" - is safer
    Const dFirst As String = "A2" ' Destination First Cell Address
    Const dLower As Long = 3 ' first column to write the cell values to
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    
    Dim sPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = dwb.Path & "\"
        If .Show = -1 Then
            sPath = .SelectedItems(1)
        End If
    End With
    If sPath = "" Then Exit Sub ' dialog canceled
    
    Dim sName As String: sName = Dir(sPath & "\" & sPattern)
    If Len(sName) = 0 Then
        MsgBox "No files in the Directory"
        Exit Sub
    End If
    
    Dim sAddresses() As String: sAddresses = Split(sAddressesList,",")
    Dim aUpper As Long: aUpper = UBound(sAddresses)
    Dim cCount As Long: cCount = dLower + aUpper
    
    Application.ScreenUpdating = False
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim Dat As Variant: ReDim Dat(1 To cCount)
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim n As Long
    Dim a As Long
    
    ' Write each worksheet's results to an array ('Dat') and add the array
    ' to the dictionary ('dict').
    Do While sName <> ""
        Set swb = Workbooks.Open(sPath & "\" & sName)
        Dat(1) = swb.Name
        Dat(2) = sPath ' or swb.Path - it's always the same '***
        For Each sws In swb.Worksheets
            If LCase(sws.Name) Like swsPatternLCase Then
                'Dat(2) = sws.Name ' looks more useful '***
                For a = 0 To aUpper
                    Dat(dLower + a) = sws.Range(sAddresses(a)).Value
                Next a
                n = n + 1
                dict.Add n,Dat
            End If
        Next sws
        swb.Close False
        sName = Dir()
    Loop
    
    Dim rCount As Long: rCount = dict.Count
    
    If rCount > 0 Then
        
        ' Write the results from the arrays in the dictionary
        ' to a 2D one-based array ('dData').
        Dim dData As Variant: ReDim dData(1 To rCount,1 To cCount)
        Dim r As Long
        Dim c As Long
        For Each Dat In dict.Items
            r = r + 1
            For c = 1 To cCount
                dData(r,c) = Dat(c)
            Next c
        Next Dat
        
        With dwb.Worksheets(dID).Range(dFirst).Resize(,cCount)
            ' Write the results to the destination range (in one go).
            .Resize(rCount).Value = dData
            ' Clear the contents below the destination range.
            .Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
                .Offset(rCount).ClearContents
            .EntireColumn.AutoFit
        End With

        dwb.Save
    
    End If
    
    Application.ScreenUpdating = True
    
    MsgBox "Data collected.",vbInformation,"Collect Data"
    
End Sub