Excel 宏，用于根据工作表名称将多个工作表合并到主工作表

Question

所以，我有一个包含大约 80 张工作表的 Excel 工作簿，这些工作表被命名为 Input、Input(1)、input、INPUT、INPUT(2) 和 Output、Output(1)、Output(2)、output，输出等等，你明白了......我想创建一个宏，它在名为“MASTERSHEET INPUT”和“MASTERSHEET Output”的工作簿中创建两个母版表。宏应从其工作表名称中具有任何输入变化的任何工作表中复制所有数据，并将其粘贴到 MASTERSHEET INPUT 中，对于名为 output 的工作表也是如此，它将被粘贴到 MASTERSHEET OUTPUT 中。我对 VBA 比较陌生，如果有人可以帮助我，我将不胜感激。 提前致谢！

这是我之前使用的代码

 Sub CombineData()

    Dim I As Long
    Dim xRg As Range

    On Error Resume Next

    Worksheets.Add Sheets(1)

    ActiveSheet.Name = "MasterSheet"

   For I = 2 To Sheets.Count
        Set xRg = Sheets(1).UsedRange

        If I > 2 Then
            Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
        End If

        Sheets(I).Activate
        ActiveSheet.UsedRange.Copy xRg
    Next

 End Sub

但这会将工作簿中的所有工作表合并为一个而不检查工作表名称。

接下来我尝试使用这个，但这只是将第一个输出表粘贴到两个母版表中，然后结束：

 Sub CombineData()

    Dim I As Long
    Dim xRg As Range
    Dim xWs As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    
    On Error Resume Next
    Worksheets.Add Sheets(1)

    ActiveSheet.Name = "MasterSheet Output"

   For I = 2 To Sheets.Count
        
        Set xRg = Sheets(1).UsedRange

        If I > 2 Then
            Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
        End If
        For Each xWs In Application.ActiveWorkbook.Worksheets
        If xWs.Name = "OUTPUT*" Or xWs.Name = "output*" Or xWs.Name = "Output*" Then
             
        Sheets(I).Activate
        ActiveSheet.UsedRange.Copy xRg
        End If
        Next
        
    Next

On Error Resume Next

    Worksheets.Add Sheets(1)

    ActiveSheet.Name = "MasterSheet Input"

   For I = 3 To Sheets.Count
        Set xRg = Sheets(1).UsedRange

        If I > 2 Then
            Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
        End If
        For Each xWs In Application.ActiveWorkbook.Worksheets
        If xWs.Name = "INPUT*" Or xWs.Name = "input*" Or xWs.Name = "Input*" Then
             
        Sheets(I).Activate
        ActiveSheet.UsedRange.Copy xRg
        End If
        Next
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
Call DeleteAllSheetsExceptMaster

End Sub

我也尝试过使用它，但这完全没有任何作用：

Sub CombineData()
  

    Dim I As Long
    Dim xrg As Range
    Dim counter As Long
    Dim xWs1 As Worksheet
    Dim xWs2 As Worksheet

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
        
        For counter = 1 To 2
        Worksheets.Add Sheets(1)
        If counter = 1 Then
        ActiveSheet.Name = "MasterSheet Input"
        Set xWs1 = ActiveSheet
        End If
        
        If counter = 2 Then
        ActiveSheet.Name = "MasterSheet Output"
        Set xWs2 = ActiveSheet
        End If
        
        Next counter
        
        For I = 2 To Sheets.count
        
            Set xrg = Sheets(1).UsedRange
        
            If I > 2 Then
                
                Set xrg = Sheets(1).Cells(xrg.Rows.count + 1, 1)
            
            End If

        Sheets(I).Activate
        
            If Sheets(I).Name = "OUTPUT*" Or Sheets(I).Name = "output*" Or Sheets(I).Name = "Output*" Then
             
                ActiveSheet.UsedRange.Copy xWs2
                    
            End If
        
            If Sheets(I).Name = "INPUT*" Or Sheets(I).Name = "input*" Or Sheets(I).Name = "Input*" Then
             
                ActiveSheet.UsedRange.Copy xWs1
                    
            End If
        Next
        
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Answer 1

创建主表

• 以下内容将删除每个存在的主工作表，然后创建新的。然后它将数据从定义的源工作表的 A1 开始的当前区域复制到适当的主工作表（阅读 OP 的要求）。

守则

Option Explicit

Sub createMasterSheets()
    
    ' Define constants incl. the Names Arrays and the workbook.
    Const srcFirst As String = "A1"
    Const tgtFirst As String = "A1"
    Dim srcNames As Variant
    srcNames = Array("iNpUt", "oUtPuT") ' Case does not matter.
    Dim tgtNames As Variant
    tgtNames = Array("MasterIn", "MasterOut")
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define lower and upper subscripts of the 1D arrays:
    ' srcNames, tgtNames, Dicts
    Dim sFirst As Long
    sFirst = LBound(srcNames)
    Dim sLast As Long
    sLast = UBound(srcNames)
    
    ' Turn off screen updating.
    Application.ScreenUpdating = False
    
    ' Add Target Worksheets.
    Dim ws As Worksheet
    Dim n As Long
    For n = sLast To sFirst Step -1
        On Error Resume Next
        Set ws = wb.Sheets(tgtNames(n))
        On Error GoTo 0
        If Not ws Is Nothing Then
            Application.DisplayAlerts = False
            wb.Sheets(tgtNames(n)).Delete
            Application.DisplayAlerts = True
        End If
        wb.Worksheets.Add Before:=wb.Sheets(1)
        ActiveSheet.Name = tgtNames(n)
    Next n
        
    ' Define Dictionaries Array and populate it with Dictionaries.
    ' The Dictionaries will hold the Data Arrays.
    Dim Dicts As Variant
    ReDim Dicts(sFirst To sLast)
    Dim dict As Object
    For n = sFirst To sLast
        Set dict = CreateObject("Scripting.Dictionary")
        Set Dicts(n) = dict
    Next n
    
    ' Declare variables.
    Dim wsName As String ' Current Worksheet Name
    Dim rng As Range     ' Current Source Range, Current Target Cell Range
    Dim m As Long        ' Subscript of Current Data Array in Current Dictionary
                         ' of Dictionaries Array
    
    ' Write values from Source Ranges to Data Arrays.
    For Each ws In wb.Worksheets
        wsName = ws.Name
        For n = sFirst To sLast
            If InStr(1, wsName, srcNames(n), vbTextCompare) = 1 Then
                ' Define Source Range. You might need to do this in another way.
                Set rng = ws.Range(srcFirst).CurrentRegion
                m = m + 1
                Dicts(n)(m) = rng.Value ' This will fail later if one cell only.
                Exit For
            End If
        Next n
    Next ws
    
    ' Declare variables
    Dim Key As Variant ' Current Key in Current Dictionary
                       ' of Dictionaries Array.
    
    ' Write values from Data Arrays to Target Ranges.
    For n = sFirst To sLast
        Set rng = wb.Worksheets(tgtNames(n)).Range(tgtFirst)
        Set ws = wb.Worksheets(tgtNames(n))
        For Each Key In Dicts(n).Keys
            rng.Resize(UBound(Dicts(n)(Key), 1), _
                       UBound(Dicts(n)(Key), 2)).Value = Dicts(n)(Key)
            Set rng = rng.Offset(UBound(Dicts(n)(Key), 1))
        Next Key
    Next n
    
    ' Turn on screen updating.
    Application.ScreenUpdating = True
    
    ' Inform user.
    MsgBox "Sheets created, data transferred.", vbInformation, "Success"
                
End Sub

Answer 2

看看这是否适合你。

编辑：固定区分大小写。

Sub CopyFromWorksheets()
    Dim wrk As Workbook 'Workbook object - Always good to work with object variables
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Input Master
    Dim trg2 As Worksheet 'Output Master
    Dim rng As Range 'Range object
     
    Set wrk = ActiveWorkbook 'Working in active workbook
     

     'Add new worksheet as the last worksheet
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
     'Rename the new worksheet
    trg.Name = "Input Master"
    'Add new worksheet as the last worksheet
    Set trg2 = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
     'Rename the new worksheet
    trg2.Name = "Output Master"
         
     
     'We can start loop
    For Each sht In wrk.Worksheets
         'If worksheet in loop is the last one, stop execution (it is Master worksheet)
        If sht.Index = wrk.Worksheets.Count - 1 Then
            Exit For
        ElseIf LCase(sht.Name) Like "*" & "input" & "*" Then
                Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
         'Put data into the Master worksheet
        trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
        ElseIf LCase(sht.Name) Like "*" & "output" & "*" Then
                Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
         'Put data into the Master worksheet
        trg2.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
        End If
               
        
    Next sht
     'Fit the columns in Master worksheet
    trg.Columns.AutoFit
    trg.Rows(1).Delete
    trg.Columns.AutoFit
    trg2.Rows(1).Delete

End Sub