複数のシートのデータを統合するExcel

Question

私は、書式設定を標準化するために数式で実行したレポートデータを6枚持っています。これらのシートでは、私が必要とするデータは、列AL:BWにあり、長さが異なり、ヘッダーが一致しています。

ここでは、すべてのデータを集計シートにまとめて、グラフ/レポートをより簡単に作成する必要があります。私はVBAが解決できるとはかなり確信していますが、私は各シートの同じ列範囲を選択し、そのデータを要約シートにコンパイルすることができる回答をオンラインで見つけられませんでした。

私はこのarticleから解決策を試してきましたが、具体的にはAL:BW列のデータをターゲットにするためのVBAについては十分に分かりません。

Sub CopyData() 

    Dim sh As Worksheet 
    Dim DestSh As Worksheet 
    Dim Last As Long 
    Dim shLast As Long 
    Dim CopyRng As Range 
    Dim StartRow As Long 

    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    ' Delete the summary sheet if it exists. 
    Application.DisplayAlerts = False 
    On Error Resume Next 
    ActiveWorkbook.Worksheets("CombinedData").Delete 
    On Error GoTo 0 
    Application.DisplayAlerts = True 

    ' Add a new summary worksheet. 
    Set DestSh = ActiveWorkbook.Worksheets.Add 
    DestSh.Name = "CombinedData" 

    ' Fill in the start row. 
    StartRow = 2 

    ' Loop through all worksheets and copy the data to the 
    ' summary worksheet. 
    For Each sh In ActiveWorkbook.Worksheets 
     If LCase(Left(sh.Name, 4)) = "?-??" Then 


      ' If source worksheet is not empty and if the last 
      ' row >= StartRow, copy the range. 
      If shLast > 0 And shLast >= StartRow Then 
       'Set the range that you want to copy 
       Set CopyRng = sh.Range("AL:BL") 

       ' Test to see whether there are enough rows in the summary 
       ' worksheet to copy all the data. 
       If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then 
        MsgBox "There are not enough rows in the " & _ 
        "summary worksheet to place the data." 
        GoTo ExitTheSub 
       End If 

       ' This statement copies values and formats. 
       CopyRng.Copy 
       With DestSh.Cells(Last + 1, "A") 
        .PasteSpecial xlPasteValues 
        .PasteSpecial xlPasteFormats 
        Application.CutCopyMode = False 
       End With 


End Sub 

私は助けてくれてありがとう！

Answer 1

これは、必要な操作を行う必要があります。コピー範囲を変更するだけです。

'Fill in the range that you want to copy 
'Set CopyRng = sh.Range("A1:G1") 

Sub CopyRangeFromMultiWorksheets() 
    Dim sh As Worksheet 
    Dim DestSh As Worksheet 
    Dim Last As Long 
    Dim CopyRng As Range 

    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    'Delete the sheet "RDBMergeSheet" if it exist 
    Application.DisplayAlerts = False 
    On Error Resume Next 
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete 
    On Error GoTo 0 
    Application.DisplayAlerts = True 

    'Add a worksheet with the name "RDBMergeSheet" 
    Set DestSh = ActiveWorkbook.Worksheets.Add 
    DestSh.Name = "RDBMergeSheet" 

    'loop through all worksheets and copy the data to the DestSh 
    For Each sh In ActiveWorkbook.Worksheets 
     If sh.Name <> DestSh.Name Then 

      'Find the last row with data on the DestSh 
      Last = LastRow(DestSh) 

      'Fill in the range that you want to copy 
      Set CopyRng = sh.Range("A1:G1") 

      'Test if there enough rows in the DestSh to copy all the data 
      If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then 
       MsgBox "There are not enough rows in the Destsh" 
       GoTo ExitTheSub 
      End If 

      'This example copies values/formats, if you only want to copy the 
      'values or want to copy everything look at the example below this macro 
      CopyRng.Copy 
      With DestSh.Cells(Last + 1, "A") 
       .PasteSpecial xlPasteValues 
       .PasteSpecial xlPasteFormats 
       Application.CutCopyMode = False 
      End With 

      'Optional: This will copy the sheet name in the H column 
      DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name 

     End If 
    Next 

ExitTheSub: 

    Application.Goto DestSh.Cells(1) 

    'AutoFit the column width in the DestSh sheet 
    DestSh.Columns.AutoFit 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 
End Sub 


Function LastRow(sh As Worksheet) 
    On Error Resume Next 
    LastRow = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Row 
    On Error GoTo 0 
End Function 


Function LastCol(sh As Worksheet) 
    On Error Resume Next 
    LastCol = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByColumns, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Column 
    On Error GoTo 0 
End Function