将多个工作表合并为一个工作表

Question

我想在同一Excel中将多个工作表合并为一个工作表，但是我不希望在所有工作表中的特定单词“总计”之后添加一些数据。我应该怎么做才能删除单词“总计”之后的数据，然后合并所有工作表。 下面的代码是用来添加多个工作表的。

Sub Consolidate()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim erow As Long, lrowsh As Long, startrow As Long
Dim CopyRng As Range
startrow = 3
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Deleting "Consolidate" sheet
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Consolidate").Delete
On Error GoTo 0
Application.DisplayAlerts = True



'Adding worksheet with the name "Consolidate"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Consolidate"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the next blank or empty row on the DestSh
erow = DestSh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
'Find the last row with data in the Sheet
lrowsh = sh.Range("A" & Rows.Count).End(xlUp).Row



Set CopyRng = sh.Range(sh.Rows(startrow), sh.Rows(lrowsh))

'copies Values / formats
CopyRng.Copy
With DestSh.Cells(erow, 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

End If
Next
End Sub

Answer 1

Interesting Workbook Consolidation

Change the constants (Const) to fit your needs.

The Code

Sub Consolidate()

    ' Target
    Const cTarget As String = "Consolidate"   ' Target Worksheet Name
    ' Source
    Const cFR As Long = 3             ' First Row Number
    Const cLRC As Variant = 1         ' Last-Row Column Letter/Column Number
    Const cCrit As String = "Total"   ' Criteria

    Dim wb As Workbook    ' Target Workbook
    Dim wsT As Worksheet  ' Target Worksheet
    Dim ws As Worksheet   ' Current Source Worksheet
    Dim eRow As Long      ' Target First Empty Row
    Dim lRow As Long      ' Source Last Used Row
    Dim lCol As Long      ' Source Last Used Column
    Dim rngCell As Range  ' Cell Ranges
    Dim rng As Range      ' Ranges

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Create a reference to Target Workbook. If the code will NOT be in the
    ' workbook to be processed, then use its name (preferable) or
    ' ActiveWorkbook instead of ThisWorkbook.
    Set wb = ThisWorkbook

    ' Note: Instead of the following with block you could use code to clear
    '       or clear the contents of the Target Worksheet.
    With wb
        'Delete Target Worksheet.
        Application.DisplayAlerts = False
        On Error Resume Next
        .Worksheets("Consolidate").Delete
        On Error GoTo 0
        Application.DisplayAlerts = True
        'Add Target Worksheet.
        Set wsT = .Worksheets.Add(Before:=.Sheets(1)) ' First Tab
        wsT.Name = "Consolidate"
    End With

    ' Handle errors.
    On Error GoTo ErrorHandler

    ' Loop through all worksheets.
    For Each ws In wb.Worksheets
        If ws.Name <> wsT.Name Then
            With ws.Cells(cFR, cLRC).Resize(ws.Rows.Count - cFR + 1, _
                    ws.Columns.Count - cLRC + 1)
                ' Note: Choose only one of the following two lines.
                'Find the first occurrence of Criteria in Current Worksheet.
                Set rngCell = .Find(cCrit, .Cells(.Rows.Count, .Columns _
                        .Count), xlValues, xlWhole, xlByRows, xlNext)
'                   'Find the last occurrence of Criteria in Current Worksheet.
'                    Set rng = .Find(cCrit, , xlValues, xlWhole, xlByRows, _
'                            xlPrevious)
                ' Clear the range below the row where Criteria was found.
                ws.Rows(rngCell.Row + 1 & ":" & ws.Rows.Count).Clear
                ' Create a reference to Row Range (of Copy Range).
                Set rng = .Cells(1).Resize(rngCell.Row - cFR + 1, _
                        .Columns.Count - cLRC + 1)
            End With
            ' Create a reference to last cell in last column of Row
            ' Range (of Copy Range).
            Set rngCell = rng.Find("*", , xlFormulas, , _
                    xlByColumns, xlPrevious)
            ' Create a reference to Copy Range.
            Set rng = rng.Cells(1).Resize(rng.Rows.Count, _
                    rngCell.Column - cLRC + 1)

            'Find the next blank or empty row in Target Worksheet.
            eRow = wsT.Cells(wsT.Rows.Count, cLRC).End(xlUp) _
                    .Offset(1, 0).Row
            ' Copy Copy Range.
            rng.Copy
            ' In (First Empty Row of) Target Worksheet
            With wsT.Cells(eRow, 1)
                ' First paste the formats to avoid trouble mostly when pasting
                ' dates or time. Excel might firstly format it differently, and
                ' when pasting the formats might not revert to desired formats.
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteValues
                Application.CutCopyMode = False
            End With

        End If

    Next

    ' Go to the top of Target Worksheet.
    ActiveSheet.Range("A1").Select

    ' Inform user of success (Since the code is fast, you might not know if it
    ' had run at all).
    MsgBox "The operation finished successfully.", vbInformation, "Success"

ProcedureExit:

    ' Speed down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:

    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub