異なるシートからデータを引っ張ってExcelでテーブルを作成する

Question

1,2,3,4という番号の異なるシートからデータを取り出すことによって "効率"シートにテーブルを作成しようとしています。構築しようとすると8つの列があります。そのうち1つは日付です。日付は、シートの1つのセル、セルG4にのみあり、すべてのシート上の同じ場所です。他の列は列B、C、D、E、F、OおよびQから来ており、9行目から下方に向かっています。私たちがシート1から2から3などに行くと、列のサイズが変わることがあります。データだけをコピーしたいだけです。行20まではいくつかの書式設定がありますが、固定数の行をデータの数だけコピーする必要はありません。この情報を「効率」シートに貼り付けると、書式ではなくデータのみが必要になります。私はまた、他のデータポイントの長さとそれが撮影された "日付"シートと一致する日付列の長さが必要です。私はまた、ビルドされているテーブルの最初の行にタイトル行が1回だけ必要で、項目は "日付"とB、C、D、E、F、O、Q列の行8です（これはすべての "日付"シートで同じですが、 "効率"シートの表ヘッダーに必要なのは一度だけです）。誰も私がこれを実現するのを助けることができるだろうか？

おかげ

'

Sub DataTable() 

Dim wsTable As Worksheet 
Set wsTable = Worksheets("Efficiency") 'change as needed 

Dim ws As Worksheet 

For Each ws In ThisWorkbook.Worksheets 

    Select Case ws.Name 

     Case Is = "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15" 

      With ws 

       Dim rngData As Range 
       Set rngData = Union(.Range("B:F"), .Range("O:O"), .Range("Q:Q")) 

       Dim lRow As Long 
       Dim rCheck As Range 
       For Each rCheck In Intersect(rngData, .Rows(1)) 

        If .Cells(.Rows.Count, rCheck.Column).End(xlUp).Row > lRow Then 
         lRow = .Cells(.Rows.Count, rCheck.Column).End(xlUp).Row 
        End If 

       Next 

         Dim dDate As Date 
         dDate = .Range("G4").Value 


        With wsTable 

        .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(lRow, 1).Value = dDate 
        ws.Range("B9:F" & lRow).Copy 
        .Range("B" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues 
        ws.Range("O9:O" & lRow).Copy 
        .Range("O" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues 
        ws.Range("Q9:O" & lRow).Copy 
        .Range("Q" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial x1PasteValues 

       End With 

      End With 

    End Select 

Next 

End Sub 

'

Answer 1

私はあなたがやろうとしているかを理解だと思います。私はあなたがそれを必要以上に少し難しくしようとしていると思います。ここでは、いくつかのループを使用して作成したコードを使用して、必要なものを取得します。シートの日付を変数にコピーします。次に、最初の列に「日付」という語を置き、ヘッダー列をB〜Iにしました。それに応じて調整することができます。

Dim rowDate As Date 

Sheets("Sheet1").Select 
rowDate = Cells(4, 7) 

Range("B9").Select 
' Copy the header rows & make the word Date the first column 
Sheets("Efficiency").Range("A1") = "Date" 
Range("B8:F8").Copy 
Sheets("Efficiency").Range("B1").PasteSpecial xlPasteValues 
Range("O8").Copy 
Sheets("Efficiency").Range("H1").PasteSpecial xlPasteValues 
Range("Q8").Copy 
Sheets("Efficiency").Range("I1").PasteSpecial xlPasteValues 

' Cycle throught the sheets and copy the data 
' Each array item is the sheet name. 

Dim SheetArray(4) As String 
SheetArray(0) = "Sheet1" 
SheetArray(1) = "Sheet2" 
SheetArray(2) = "Sheet3" 
SheetArray(3) = "Sheet4" 

Dim EffRow As Integer ' Keep track of the correct row on the Efficiency sheet 
Dim EffCell As String ' Track the cell for effeciency 
EffRow = 2 
For i = 0 To 3 

    Sheets(SheetArray(i)).Select 
    rowDate = Cells(4, 7) 
    Range("B9").Select 

    ' Loop until a blank cell is reached 
    Do While Not (IsEmpty(ActiveCell)) 
     EffCell = "A" & EffRow 
     Sheets("Efficiency").Range(EffCell) = rowDate 
     Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + 5)).Copy 
     EffCell = "B" & EffRow 
     Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues 
     ActiveCell.Offset(0, 13).Copy 
     EffCell = "H" & EffRow 
     Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues 
     EffCell = "I" & EffRow 
     Sheets("Efficiency").Range(EffCell).PasteSpecial xlPasteValues 
     EffRow = EffRow + 1 
     ActiveCell.Offset(1, 0).Activate 
    Loop 
Next i 

End Subの

うまくいけば、これは正しい方向にあなたを操縦します。