从每个选项卡中提取一列数据并将所有数据粘贴到一个选项卡上

Question

我有一个包含 102 个选项卡的 excel 电子表格——每个选项卡的格式都相同，有几列操作。我想从每个选项卡复制同一列数据并将其放在同一个工作表中的单个选项卡上，但我不知道如何将每个副本粘贴到不同的列中。

这个问题与这里提出的问题非常相似： Extract tabular data from every Excel tab, and paste data on a single sheet

我尝试了以下代码的许多变体，但无法弄清楚。我收到以下错误：

对象“_Worksheet”的方法“范围”失败

我已经粘贴了下面的代码。提前感谢您的任何帮助！

Option Explicit


Sub CopyPasteCombineSI()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim rngSI As Range, rngHeading As Range
Dim LColO As Long, LRowI As Long, LastColumn As Long

'~~> Set your Output Sheet
Set wsOutput = ThisWorkbook.Sheets("Dual Flow")

'~~> Loop through all sheets to copy and paste combined SI data
For Each wsInput In ThisWorkbook.Worksheets
    '~~> Ensure that we ignore the output sheet
    If wsInput.Name <> wsOutput.Name Then
        '~~> Working with the input sheet
        With wsInput
            '~~> Set your range for copying
            Set rngHeading = .Range("E1")
            '~~> Copy your range
            rngHeading.Copy
            '~~> Paste
            .Range("F1").PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            '~~> Get the last row of input sheet
            LRowI = .Range("A" & .Rows.Count).End(xlUp).Row
            '~~> Set your range for copying
            Set rngSI = .Range("F1:F" & LRowI)
            '~~> Copy your range
            rngSI.Copy
            '~~> Pasting data in the output sheet
            With wsOutput
                If WorksheetFunction.CountA(Cells) > 0 Then
                    'Search for any entry, by searching backwards by Columns.
                    LastColumn = Cells.Find(What:="*", After:=[A1], _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious).Column
                Else
                    LastColumn = 0
                End If
                '~~> Get the next available column in output sheet for pasting
                LColO = LastColumn + 1

                '~~> Finally paste
                .Range(LColO & "1").PasteSpecial Paste:=xlPasteValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            End With
        End With
    End If
Next wsInput

Exit Sub
End Sub

Answer 1

除了@Scott Craner说的，你还可以把代码缩短成这样：

Sub CopyPasteCombineSI()

Dim wsInput As Worksheet, wsOutput As Worksheet
Dim LRowI As Long

'~~> Set your Output Sheet
Set wsOutput = ThisWorkbook.Sheets("Dual Flow")

For Each wsInput In ThisWorkbook.Worksheets
    '~~> Ensure that we ignore the output sheet
    If wsInput.Name <> wsOutput.Name Then
        '~~> Working with the input sheet
        With wsInput
            '~~> Set your range for copying
            .Range("F1").Value = .Range("E1").Value
            '~~> Get the last row of input sheet
             LRowI = .Range("A" & .Rows.Count).End(xlUp).Row
            '~~> Copy your range
            .Range("F1:F" & LRowI).Copy
            '~~> paste range to next available column, assumes headers in row 1 
            wsOutput.Cells(1, wsOutput.Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial xlPasteValues
        End With
    End If
Next

End Sub

完全删除剪贴板（复制和粘贴）。

使用这个：

With wsOutput
    .Cells(1,.Columns.Count).End(xlToLeft).Offset(, 1).Resize(LRowI).Value = wsInput.Range("F1:F" & LRowI).Value
End With

代替复制和粘贴的两行。