Question

我有一本excel工作簿，该工作簿具有相同布局的每个月的发票数据。我想知道是否有一个宏可以复制每张工作表中的数据并将它们粘贴在一起。

因此，第一张纸是P1，然后是P2，P3等，直到P12。我想要一个宏，它将P1数据粘贴到新工作表上，然后将P2数据粘贴到新工作表下，然后将P3等粘贴到最后。

我想这将是某种For循环，但是我不确定代码是什么样（我对vba还是很陌生）

预先感谢您！

Answer 1

因为要了解表单的结构非常有限，所以我尝试创建通用代码，并对其进行一些修改以满足您的需求。

Option Explicit

Sub test()

Dim wsTest As Worksheet, ws As Worksheet
Dim LRW As Long, LRF As Long, LCW As Long

'Here we create a separate sheet namded wsFull to paste the data in it.
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets("wsFull")
On Error GoTo 0

If wsTest Is Nothing Then
    Worksheets.Add.Name = "wsFull"
End If

Set wsTest = ActiveWorkbook.Worksheets("wsFull")

'Here we loop all sheets except the new sheet named wsFull
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "wsFull" Then

        With ws
            'Here we find last column (using first row) & last row (using Column A) for each sheet we loop
            LRW = .Cells(.Rows.Count, "A").End(xlUp).Row
            LCW = .Cells(1, .Columns.Count).End(xlToLeft).Column
        End With

        'Here we find the last row of wsFull in order to find where we will paste the data in.
        LRF = wsTest.Cells(wsTest.Rows.Count, "A").End(xlUp).Row

            'We paste the data in column A
            If LRF = 1 And wsTest.Range("A1").Value = "" Then
                ws.Range(ws.Cells(1, 1), ws.Cells(LRW, LCW)).Copy wsTest.Range("A1")
            Else
                ws.Range(ws.Cells(1, 1), ws.Cells(LRW, LCW)).Copy wsTest.Range("A" & LRF + 1)
            End If

    End If

Next ws

End Sub

Answer 2

这个选项怎么样？

Sub CopyDataWithoutHeaders()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "RDBMergeSheet" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    'Fill in the start row
    StartRow = 2

    '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 last row with data on the DestSh and sh
            Last = LastRow(DestSh)
            shLast = LastRow(sh)

            'If sh is not empty and if the last row >= StartRow copy the CopyRng
            If shLast > 0 And shLast >= StartRow Then

                'Set the range that you want to copy
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

                'Test if there enough rows in the DestSh to copy all the data
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "There are not enough rows in the Destsh"
                    GoTo ExitTheSub
                End If

                'This example copies values/formats, if you only want to copy the
                'values or want to copy everything look below example 1 on this page
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With

            End If

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

https://www.rondebruin.nl/win/s3/win002.htm

vba宏可一次又一次粘贴多个工作表中的数据

2 个答案: