Question

我尝试制作一个宏来浏览每张纸和每张纸，复制到B4：Y的最后一行，然后将其粘贴到名为＆＃34; Total＆＃34;从B4开始。

例如：

我有5张名为：a，b，c，d，e。我的宏应该复制和粘贴来自＆＃34; a＆＃34;的50行在B4：Y54和60行来自＆＃34; b＆＃34;在B55：Y115 ......等等上。

我尝试在网上查询，但我无法使用我的代码。请帮助，非常感谢！

Sub TransferData()
    Dim LTot As Integer ' represents the line in the total tab
    Dim WsTot As Worksheet ' represents your sheet tab
    Dim i As Integer

    Set WsTot = ThisWorkbook.Sheets("Total") 'declare your Total tab
    WsTot.Range("B4:Y10000").Clear ' clear the old data

    For i = 1 To 5 ' numbers of your tabs
        With ThisWorkbook.Sheets("" & i)
            .Range(.Cells(4, 2), .Cells(.Range("B10000").End(xlUp).Rows, 25)).Copy WsTot.Cells(LTot, 2)
            LTot = LTot + .Range("B10000").End(xlUp).Rows - 4
        End With
    Next

End Sub

Answer 1

以下代码将按照您在问题中的描述执行。您的代码中存在一些问题，而不是以此为基础，我已经以自己的方式重写了代码。

Sub TransposeData()
    Dim wsList() As String, wsName As Variant, ws As Worksheet
    Dim wsTotal As Worksheet: Set wsTotal = ThisWorkbook.Sheets("Total")
    Dim minRow As Long, maxRow As Long, nextRow As Long

    wsList = Split("a,b,c,d,e", ",")

    For Each wsName In wsList
        Set ws = ThisWorkbook.Sheets(wsName)
        maxRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
        Select Case wsName
            Case "a"
                minRow = 4
            Case "b"
                minRow = 55
            Case "c"
                minRow = 116
            Case "d"
                minRow = 171
            Case "e"
                minRow = 181
        End Select

        nextRow = wsTotal.Range("B" & wsTotal.Rows.Count).End(xlUp).Row + 1

        ws.Range("B" & minRow & ":Y" & maxRow).Copy wsTotal.Range("B" & nextRow)
    Next wsName
End Sub

以下是为满足OP特定需求而量身定制的相同代码：

Sub TransposeData()
    Dim wsList() As String, wsName As Variant, ws As Worksheet
    Dim wsTotal As Worksheet: Set wsTotal = ThisWorkbook.Sheets("Total")
    Dim minRow As Long, maxRow As Long, nextRow As Long

    wsList = Split("Engineering Salary,Mailroom Salary,Reception Salary,D0 Salary,Dock Worker Salary", ",")

    For Each wsName In wsList
        Set ws = ThisWorkbook.Sheets(wsName)
        maxRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
        Select Case wsName
            Case "Engineering Salary"
                minRow = 1
            Case "Mailroom Salary"
                minRow = 1
            Case "Reception Salary"
                minRow = 1
            Case "D0 Salary"
                minRow = 1
            Case "Dock Worker Salary"
                minRow = 1
        End Select

        nextRow = wsTotal.Range("B" & wsTotal.Rows.Count).End(xlUp).Row + 1

        ws.Range("B" & minRow & ":Y" & maxRow).Copy 
        wsTotal.Range("B" & nextRow).PasteSpecial xlPasteValues
        Application.CutCopyMode = xlCopy
    Next wsName
End Sub

我的工作表标签如下所示：

5张纸中的每一张分别在单元格B1中具有1,2,3,4,5。运行代码后，我的＆＃34; Totals＆＃34;表格如下：

Answer 2

您的总工作表需要被称为Total，它将循环遍历工作簿的所有活动工作表

Option Explicit
Sub Outlier()
Dim ws As Worksheet
Dim wsc As Workbook

Set wsc = Workbooks(ActiveWorkbook.name)
For Each ws In ActiveWorkbook.Worksheets
    If ws.name <> "Total" And Sheets("Total").Range("A1") = vbNullString Then
    ws.Range("A1:" & ws.Range("A1").SpecialCells(xlCellTypeLastCell).Address).Copy Destination:=Sheets("Total").Range("A1")
    ElseIf ws.name <> "Total" And Sheets("Total").Range("A1") <> vbNullString Then
    ws.Range("A1:" & ws.Range("A1").SpecialCells(xlCellTypeLastCell).Address).Copy Destination:=Sheets("Total").Range("A1").End(xlDown).Offset(1, 0)
    End If
Next
End Sub

如果你想做特定的列，那么你需要清楚所有的列名，但是你需要做类似的事情

Set wsc = Workbooks(ActiveWorkbook.name)
For Each ws In ActiveWorkbook.Worksheets
    If ws.name <> "Total" And Sheets("Total").Range("A1") = vbNullString Then
    ws.Range("B1:B" & ws.Range("B1").SpecialCells(xlCellTypeLastCell).row).Copy Destination:=Sheets("Total").Range("B1")
    ElseIf ws.name <> "Total" And Sheets("Total").Range("A1") <> vbNullString Then
    ws.Range("B1:B" & ws.Range("A1").SpecialCells(xlCellTypeLastCell).oww).Copy Destination:=Sheets("Total").Range("B1").End(xlDown).Offset(1, 0)
    End If
Next
End Sub

VBA复制多个工作表并粘贴到另一个工作表

2 个答案: