Question

我有一个包含100张的Excel工作簿（名为Peak）（每张Sheet以Sheet1开头，后跟唯一名称Sheet1AA），我想从每张Peak Sheet中复制一列并粘贴到一个新的工作簿（名为Table）使用转置，因此Table将有来自Peak Workbook Sheets的100行数据。下面是复制然后粘贴两个工作表的示例，第二个工作表（Sheet1BB）粘贴在表中第一个工作表（Sheet1AA）下面。我知道我可以在复制/粘贴转置时录制宏，但希望有一种方法可以编写一个宏来连续复制/粘贴从Peak Workbook（Sheet1AA-Sheet1ZZ）到工作簿表的顺序提供100行数据，Sheet1AA中的数据是第一行，Sheet1ZZ是表中的最后一行。谢谢

Windows("Peak.xlsm").Activate
Sheets("Sheet1AA").Select
Range("O6:O150").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Table.xlsm").Activate
Range("E4:AB4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Windows("Peak.xlsm").Activate
Sheets("Sheet1BB").Select
Range("O6:O150").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Table.xlsm").Activate
Range("E5:AB5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

Answer 1

未测试：

Dim r As Long, sht As Worksheet

r = 4

For Each sht In Workbooks("Peak.xlsm").Worksheets
    sht.Range("O6:O150").Copy
    Workbooks("Table.xlsm").Sheets(1).Cells(r, "E").PasteSpecial Transpose:=True
    r = r + 1
Next sht

Answer 2

由于OP需要维护按父表名称排序的粘贴数据，因此下面是两个可能的代码：

临时助手专栏

这种方法

在列＆＃34; E＆＃34;之前插入一个（临时）列存储工作表名称的位置，而相应的数据从下一列写入到rigthwards。
在（临时）列＆＃34; E＆＃34;

删除临时列

Option Explicit

Sub Main()
    Dim iSht As Long
    Dim sht As Worksheet

    With Workbooks("Table.xlsm").Worksheets(1)
        .Columns("E").Insert '<--| insert temporary helper column
        For Each sht In Workbooks("Peak.xlsm").Worksheets '<--| loop through sheets
            sht.Range("O6:O150").Copy
            .Cells(4 + iSht, "E") = sht.Name '<--| write sheet name in temporary helper column
            .Cells(4 + iSht, "F").PasteSpecial Transpose:=True '<--| write data from the next colum rightwards
            iSht = iSht + 1
        Next sht

        With .Cells(4, "E").Resize(iSht, 146) '<--| consider temporary helper column cells containing sheet names
            .Sort key1:=.Cells(1, 1), order1:=xlAscending '<--| sort them
            .EntireColumn.Delete '<--| remove temporary helper column
        End With
    End With
End Sub

带有订购工作表名称的

数组

这需要将它们写在临时表格中（在ThisWorkbook中），对它们进行排序并将其读回（参见Function GetSortedWsNames()）

Sub Main2()
    Dim i As Long: i = 4
    Dim wb As Workbook
    Dim el As Variant

    Set wb = Workbooks("Peak.xlsm")
    With Workbooks("Table.xlsm").Worksheets(1)
       For Each el In GetSortedWsNames(wb)
           wb.Worksheets(el).Range("O6:O150").Copy
           .Cells(i, "E").PasteSpecial Transpose:=True
           i = i + 1
       Next el
    End With
End Sub


Function GetSortedWsNames(wb As Workbook) As Variant
    Dim ws As Worksheet
    Dim iSht As Long

    Set ws = ThisWorkbook.Worksheets.Add
    With wb
        For iSht = 1 To .Worksheets.Count
           ws.Cells(iSht, 1) = .Worksheets(iSht).Name
        Next iSht
    End With

    With ws.Cells(1, 1).Resize(iSht - 1)
        .Sort key1:=ws.Cells(1, 1), order1:=xlAscending
        GetSortedWsNames = Application.Transpose(.Cells)
    End With

    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
End Function

Excel宏/如何编写宏以将工作簿中的行复制/粘贴200张到表

2 个答案: