使用 VBA 代码根据特定标准将工作表合并为一张

Question

在一个工作簿中，有数百个工作表。 我正在尝试将某些工作表（其名称以“_A”或“_B”结尾）中的某个范围（A2：D6）合并到一个工作表（“组合”）中。
目标工作表的数据结构相同：

目标工作表名称都以“_A”或“_B”结尾：例如
Code1_A
Code1_B
Code2_A
Code2_B
Code3_A
Code3_B
.
.
.

我想像这样将它们组合为 VALUE 并保持 FORMAT：

目前，我有以下代码：

Sub Merge ()
Dim Sheet As Worksheet
For Each Sheet In ActiveWorkbook.Sheets
    If Sheet.Name Like "*" & strSearch & "_A" Or _
       Sheet.Name Like "*" & strSearch & "_B" Then
         Sheets(Sheet.Name).Range("A2:D6").Copy
    End If
Next

With Worksheets("Combined").Range("A2")
          .PasteSpecial Paste:=xlPasteValues
          .PasteSpecial Paste:=xlPasteFormats
End With


End Sub

*问题：我的代码查找以“_A”和“_B”结尾的工作表，但要么覆盖它们，要么获取匹配的第一个实例。 如何修复它以获取以“_A”或“_B”结尾的所有工作表并循环直到所有目标工作表的所有范围都在另一个下组合？

或者有没有其他方法可以更快地实现这一目标？

Answer 1

首先，您必须将粘贴操作移到循环中。其次，您粘贴复制值的行需要递增，否则您将一次又一次地覆盖同一区域：

    Sub Merge ()
   Dim Sheet As Worksheet
   Dim TargetRow as long


   Application.Calculation = xlCalculationManual
   Application.ScreenUpdating = False

   TargetRow = 1
   For Each Sheet In ActiveWorkbook.Sheets
      If Sheet.Name Like "*" & strSearch & "_?" Then
         Sheets(Sheet.Name).Range("A2:D6").Copy
         With Worksheets("Combined").Cells(TargetRow,1)
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
         End With
         TargetRow = TargetRow + 5
      End If
   Next
   Application.CutCopyMode = False
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
End Sub

我添加了通常的优化来暂时禁用屏幕更新和重新计算。无论如何，复制和粘贴需要很长时间，有 100 多张。有更快的方法（超过这个级别的 VBA），但是这个方法会起作用。

编辑：我使用了一个简单的“？”覆盖工作表名称中的任何单个字母。如果这对您的情况来说过于宽泛，请使用 FreeMan 建议的“或”IF 语句。
编辑：它是 Application.Calculation 而不是 Application.Calculationstate，已更正。

Answer 2

注意更新的IF 语句和移动的With 部分

Sub Merge ()
Dim Sheet As Worksheet

For Each Sheet In ActiveWorkbook.Sheets
'Note the change on this line:
  If Sheet.Name Like "*" & strSearch & "_A" or _
     Sheet.Name Like "*" & strSearch & "_B" Then
     Sheets(Sheet.Name).Range("A2:D6").Copy

    With Worksheets("Combined").Range("A2")
      .PasteSpecial Paste:=xlPasteValues
      .PasteSpecial Paste:=xlPasteFormats
    End With
  End If
Next

End Sub