Excel VBA宏，用于根据具有特定文本的工作表名称合并来自多个工作表的数据

Question

我有一个Excel工作簿，可能会添加或删除大量工作表。每个都有一个标准后缀，让我们称之为“.A”

我想要的是一个宏，对于每个带有此后缀的工作表，复制每个工作表上所选范围内的所有数据（例如：A1：X50），将其复制到新的合并工作表，移动到合并工作表的下一行并为每个后续工作表重复。到目前为止，我有这个...但它不起作用。

 Sub compile()
SelectSheets ".A", ThisWorkbook
 'Some other bits and pieces here
End Sub


Sub SelectSheets(sht As String, Optional wbk As Workbook)

Dim wks As Worksheet
Dim ArrWks() As String
Dim i As Long

If wbk Is Nothing Then Set wbk = ActiveWorkbook

ReDim ArrWks(0 To Worksheets.Count - 1)
For Each wks In Worksheets
    If InStr(1, wks.Name, sht) > 0 Then
        ArrWks(i) = wks.Name
        i = i + 1
    End If
Next wks
ReDim Preserve ArrWks(i - 1)
Sheets(ArrWks).Select

For Each ws In Sheets(ArrWks)

            ws.Range("D36:CT46").Copy
            Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
            Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Answer 1

我将对此代码进行其他更改，但基础知识如下;在哪里循环包含工作表名称的数组并进行复制。

注意：

1）您正在使用.A中的任何工作表名称，而不仅仅是将其作为后缀。

2）如果没有找到工作表，您可能还需要一些错误处理，因为您的数组最终会抛出一个越界错误。

3）如果你不测试最后一行是否为1，你的第一次粘贴将是第2行。

循环数组：

 For ws = LBound(ArrWks) To UBound(ArrWks)

对后缀的测试可能更好

If Right$(wks.Name, 2) = ".A" Then

码：

Option Explicit

Sub compile()

  SelectSheets ".A", ThisWorkbook
 'Some other bits and pieces here

End Sub


Sub SelectSheets(sht As String, Optional wbk As Workbook)

Dim wks As Worksheet
Dim ArrWks() As String
Dim i As Long

If wbk Is Nothing Then Set wbk = ActiveWorkbook

ReDim ArrWks(0 To Worksheets.Count - 1)

For Each wks In Worksheets

    If InStr(1, wks.Name, sht) > 0 Then
        ArrWks(i) = wks.Name
        i = i + 1
    End If

Next wks

ReDim Preserve ArrWks(i - 1)

Dim ws As Long

For ws = LBound(ArrWks) To UBound(ArrWks)

    Worksheets(ArrWks(ws)).Range("D36:CT46").Copy
    Worksheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)

Next ws

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub