奇妙な形の "テーブル"からのデータの平坦化

WBSで数百のテーブルが奇妙にフォーマットされたスプレッドシートがあります。奇妙な形の "テーブル"からのデータの平坦化

Iは、出発テーブルが良好先頭にヘッダを要約表に編成された溶液が見つかりました： How to "flatten" or "collapse" a 2D Excel table into 1D?

に私は2つのテーブルの作品を使用するマクロが、絶対参照を使用してデータのコピーと転置を行います。それは非常に荒いですが、私が試みたことを示すために以下に含まれています。

列（HRS、Pなど）と行（AL、Con、IHなど）の見出しは変更されていないようですので、WBSを見つけてこの情報を取得する必要があると仮定します。もう1つの問題は、テーブルの一部にTravel行の前に追加のColumn見出しがあることです（スクリーンショットの2番目の表を参照）。

特定のセルを参照せずに、WBSを検索して平坦化されたデータを記録する方法を記述するにはどうすればよいですか？

私の質問に言葉が貧弱であるか、詳細が必要な場合は教えてください。最初のマクロから

コード：

Attribute VB_Name = "Module2" 
Sub flatten_data() 
Attribute flatten_data.VB_ProcData.VB_Invoke_Func = " \n14" 
' 
' flatten_data Macro 
' 

' 
    Range("B1").Select 
    Selection.Copy 
    Sheets.Add After:=ActiveSheet 
    ActiveSheet.Paste 
    Application.CutCopyMode = False 
    Selection.AutoFill Destination:=Range("A1:A42"), Type:=xlFillDefault 
    Range("A1:A42").Select 
    ActiveSheet.Previous.Select 
    Range("F3:K3").Select 
    Selection.Copy 
    ActiveSheet.Next.Select 
    ActiveWindow.SmallScroll Down:=-45 
    Range("B1").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    Application.CutCopyMode = False 
    Selection.Copy 
    Range("B7").Select 
    ActiveSheet.Paste 
    Range("B13").Select 
    ActiveSheet.Paste 
    ActiveWindow.SmallScroll Down:=6 
    Range("B19").Select 
    ActiveSheet.Paste 
    ActiveWindow.SmallScroll Down:=9 
    Application.CutCopyMode = False 
    Selection.AutoFill Destination:=Range("B19:B42"), Type:=xlFillDefault 
    Range("B19:B42").Select 
    ActiveSheet.Previous.Select 
    Range("C6").Select 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("C16").Select 
    ActiveWindow.SmallScroll Down:=-54 
    Range("C1").Select 
    ActiveSheet.Paste 
    Application.CutCopyMode = False 
    Selection.AutoFill Destination:=Range("C1:C6"), Type:=xlFillDefault 
    Range("C1:C6").Select 
    Selection.Copy 
    ActiveSheet.Previous.Select 
    Range("C7").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("C7:C12").Select 
    ActiveSheet.Paste 
    ActiveSheet.Previous.Select 
    Range("C8").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("C13:C18").Select 
    ActiveSheet.Paste 
    ActiveSheet.Previous.Select 
    Range("C9").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("C19:C24").Select 
    ActiveSheet.Paste 
    ActiveSheet.Previous.Select 
    Range("C10").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("C25:C30").Select 
    ActiveSheet.Paste 
    ActiveSheet.Previous.Select 
    Range("C11").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    ActiveWindow.SmallScroll Down:=12 
    Range("C31:C36").Select 
    ActiveSheet.Paste 
    ActiveSheet.Previous.Select 
    Range("C12").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("C37:C42").Select 
    ActiveSheet.Paste 
    ActiveSheet.Previous.Select 
    Range("F6:K6").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    ActiveWindow.SmallScroll Down:=-33 
    Range("D1").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    Range("D7").Select 
    ActiveSheet.Previous.Select 
    Range("F7:K7").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F8:K8").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D13").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F9:K9").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D19").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F10:K10").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D25").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveWindow.SmallScroll Down:=18 
    ActiveSheet.Previous.Select 
    Range("F11:K11").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D31").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F12:K12").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D37").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("B16").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("A43:A84").Select 
    ActiveSheet.Paste 
    Range("B1:B42").Select 
    Range("B42").Activate 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveWindow.SmallScroll Down:=24 
    Range("B43").Select 
    ActiveSheet.Paste 
    Range("C1:C42").Select 
    Range("C42").Activate 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveWindow.SmallScroll Down:=27 
    Range("C43").Select 
    ActiveSheet.Paste 
    ActiveSheet.Previous.Select 
    Range("F21:K21").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D43").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F22:K22").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D49").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F23:K23").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D55").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F24:K24").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    ActiveWindow.SmallScroll Down:=12 
    Range("D61").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F25:K25").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D67").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveWindow.SmallScroll Down:=21 
    ActiveSheet.Previous.Select 
    Range("F26:K26").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D73").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
    ActiveSheet.Previous.Select 
    Range("F29:K29").Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    ActiveSheet.Next.Select 
    Range("D79").Select 
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ 
     False, Transpose:=True 
End Sub

出典

2016-06-23 jtrain

私はVBAを書く方法を学ぶことをお勧めします。レコーディングマクロは、始めるには最適な場所ですが、VBAの基本的な概念とその入力方法について学ぶ必要があります。 – Kyle

マクロを記録し、コードに戻って理解し、それをカスタマイズすることは、VBAを学ぶのに最適です。フレキシビリティを加え、何かをハードコーディングするのではなく、行/列をルーピングして特定の文字列を探すことを望むでしょう。「WBS」Googleの「excel vbaの各行をループする」というクイック検索で、私は別のスレッドに落ち着きましたhttp://stackoverflow.com/questions/1463236/loopthrough-each-row-of-range-inエクセル –

私はテーブルがWBSキーワードにオフセット同じサイズと相対のすべてをしていると仮定しています。私はまた、 "行"行が最終出力に必要でないと仮定しており、小計は必要に応じて再計算されます。

Option Explicit 

Sub Flatten_Data() 

Dim wb As Workbook 
Dim ws As Worksheet 
Dim GCell As Range 
Dim TableCell As Range 
Dim TotalTables As Integer 
Dim TableNumber As Integer 
Dim TableRow As Integer 
Dim TableColumn As Integer 
Dim ColumnHeader(6) As String 
Dim RowHeader(7) As String 

ColumnHeader(1) = "HRS" 
ColumnHeader(2) = "P" 
ColumnHeader(3) = "OH" 
ColumnHeader(4) = "G" 
ColumnHeader(5) = "C" 
ColumnHeader(6) = "F" 
RowHeader(1) = "AL" 
RowHeader(2) = "Con" 
RowHeader(3) = "IH" 
RowHeader(4) = "Mat" 
RowHeader(5) = "OD" 
RowHeader(6) = "SUB" 
RowHeader(7) = "Trav" 

Set wb = Workbooks("Book1") ' or whatever sheet holds the source data 
Set ws = Worksheets("Sheet1") ' or whatever sheet you want to copy the flattened data to 
With wb 
    With ws 
     Set GCell = .Range("A:A") 
     TotalTables = Application.WorksheetFunction.CountIf(GCell, "WBS") 
     Set GCell = .Cells.Find("WBS", .Cells(1048576, 1)) ' looks for "WBS" and ensures that it finds one in A1 if it exists 
     For TableNumber = 1 To TotalTables 
      For TableRow = 1 To 7 
       For TableColumn = 1 To 6 
        Worksheets("Sheet2").Cells(TableColumn + (TableRow - 1) * 6 + (TableNumber - 1) * 42, 4) = GCell.Offset(4 + TableRow, 4 + TableColumn).Value 
        Worksheets("Sheet2").Cells(TableColumn + (TableRow - 1) * 6 + (TableNumber - 1) * 42, 3) = RowHeader(TableRow) 
        Worksheets("Sheet2").Cells(TableColumn + (TableRow - 1) * 6 + (TableNumber - 1) * 42, 2) = ColumnHeader(TableColumn) 
        Worksheets("Sheet2").Cells(TableColumn + (TableRow - 1) * 6 + (TableNumber - 1) * 42, 1) = "1." & TableNumber 
       Next TableColumn 
      Next TableRow 
      Set GCell = .Cells.FindNext(GCell) 
     Next TableNumber 
    End With 
End With 

End Sub

テーブル番号が正しいことを確認します。そして、私はこの種のことのためにペストのような「選択」を避けるでしょう、それはコードを遅くするだけです。

出典

2016-06-23 18:57:31

奇妙な形の "テーブル"からのデータの平坦化

答えて

関連する問題