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

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

这个问题与这里提到的问题非常相似： 从每个Excel选项卡中提取表格数据，并将数据粘贴到一张表上

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

对象“_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 

代替复制和粘贴的两行。