すべてのタブから1列のデータを抽出し、すべてのデータを1つのタブに貼り付けます。

Question

102個のタブを持つスプレッドシートがあります。私は各タブから同じデータの列をコピーし、同じワークシート内の単一のタブに配置したいと思いますが、各コピーを別の列に貼り付ける方法はわかりません。

この質問は、ここで尋ねたものと非常に類似している：私は、次のコードに多くのバリエーションを試してみました Extract tabular data from every Excel tab, and paste data on a single sheet

、それを把握することはできません。次のエラーが表示されます。

Method 'Range' of object '_Worksheet' failed

以下のコードを貼り付けました。すべてのヘルプの事前のおかげで！

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 

は完全にクリップボード（コピー＆ペースト）を削除するには。コピーと貼り付け用の2つのラインの代わりに

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

：

はこれを使用してください。