使用VBA代码将工作表合并到基于特定条件的工作表中

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

例如，目标工作表名称全部以“_A”或“_B”结尾
Code1_A
Code1_B
Code2_A
Code2_B
Code3_A
Code3_B
。
。
。

我想要像这样将它们结合为VALUE并保持格式 ：

目前，我有以下代码：

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所说的那样使用和'or'ed 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