Сглаживание данных из «таблиц странности»

У меня есть таблица с сотнями таблиц, разбитых WBS, с нечетным форматированием.Сглаживание данных из «таблиц странности»

Beginning Format

What I want it to look like

Я нашел решение, в котором исходные таблицы лучше организованы в сводную таблицу с заголовками в верхней части: How to "flatten" or "collapse" a 2D Excel table into 1D?

Макрос Я использовал работы для двух таблиц, но использует абсолютные ссылки для копирования и переноса данных. Это очень грубо, но я включил ниже, чтобы показать, что я попытался.

Заголовки столбцов (HRS, P и т. Д.) И строки (AL, Con, IH и т. Д.), Похоже, не меняются, поэтому я предполагаю, что мне нужно что-то, что найдет WBS и захватит эту информацию. Другая проблема заключается в том, что некоторые таблицы имеют дополнительные заголовки столбцов перед строкой Travel (см. Вторую таблицу на скриншоте).

Как мне написать что-то, что будет искать 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» Быстрый поиск «цикл через каждую строку в excel vba» в Google приземлился на другой поток http://stackoverflow.com/questions/1463236/loop-through-each-row-of-a-range-in -excel –

Я предполагаю, что таблицы все же размера и относительного смещения для ключевого слова 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

Сглаживание данных из «таблиц странности»

ответ

Смежные вопросы