使用VBA代码将工作表合并为一个基于某些条件的工作表

Question

在一本工作簿中，有几百个工作表。 我试图将某些工作表（其名称以＆＃34; _A＆＃34;或＆＃34; _B＆＃34;）的某个范围（A2：D6）合并为一个工作表（＆＃34;合并＆＃34） ）。
目标纸张的数据结构相同：

目标表名称全部以＆＃34; _A＆＃34;或＆＃34; _B＆＃34; ： 例如
的 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

*问题：我的代码查找以＆＃34; _A＆＃34;结尾的表格和＆＃34; _B＆＃34;，但要么覆盖它们，要么获得匹配的第一个实例。 如何修复它以使所有工作表以＆＃34; _A＆＃34;结尾或＆＃34; _B＆＃34;并循环直到所有目标工作表的所有范围合并为一个？

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

Answer 1

请注意已更新的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

Answer 2

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

    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），但这个方法将起作用。

修改：我使用了一个简单的＆＃39;？＆＃39;覆盖表格中的任何一个字母。如果这种情况对您的案例来说过于宽泛，那么请使用和FreeMan建议的那样的“IF”或“IF”声明 修改：它已Application.Calculation而不是Application.Calculationstate，已更正。