Динамическое переформатирование листа excel

У меня очень грязный лист excel, который я пытаюсь переформатировать во что-то читаемое. В настоящее время он структурирован как таковой (каждое большое разделение напоминает новую ячейку):

Title1 Var1 Var1_Value Var1.1 Var1.1_Value ... Var1.K Var1.K_Value Title2 Var2 Var2_Value Var2.1 Var2.1_Value ... Var2.L Var2.L_Value ... TitleM VarM VarM_Value VarM.1 VarM.1_Value ... VarM.N VarM.N_Value 

Чтобы уточнить, количество переменных и значений для каждого столбца изменяется для каждой строки, однако каждая переменная будет иметь значение. В конечном счете, моя конечная цель – создать что-то, отформатированное как таковое:

 Title1 Var1 Var1_Value Title1 Var1.1 Var1.1_Value ... TitleM VarM.N VarM.N_Value 

Если строка заголовка повторяется для каждого Var и Var_Value в своей строке.

Я не очень много знаю о VBA, поэтому я ищу помощь на лучшем пути для достижения этого форматирования. Вот мой мыслительный процесс в psuedocode ниже, я пытался форматировать, чтобы быть VBA-esque, когда мог.

 for idx = 1 To lastRow ' Will likely have to create a function to find ' last filled column in a row -- lastColForRow tempArray = data(idx,2 To lastColforRow(idx)) for jdx = 1 To length(tempArray)-1 Step 2 newCell(end+1,1) = data(idx,1) newCell(end+1,2) = tempArray(j) newCell(end+1,3) = tempArray(j+1) next jdx next idx 

Этот код должен это сделать (обратите внимание, что он предполагает, что нет строки заголовка)

 Public Sub Reformat() Dim lastrow As Long Dim lastcol As Long Dim numrows As Long Dim i As Long, ii As Long Application.ScreenUpdating = False With ActiveSheet lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row For i = lastrow To 1 Step -1 lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column 'integer division so as to get the number of value pairs numrows = lastcol \ 2 'only do anything if we have more than one value pair If numrows > 1 Then 'insert extra rows for extra value pairs .Rows(i + 1).Resize(numrows - 1).Insert 'copy the titles down to all new rows .Cells(i, "A").Copy .Cells(i, "A").Resize(numrows) 'a value pair at a time, cut and copy to next new row For ii = 4 To lastcol Step 2 'target row is current row (i) + the value pair index ((ii /2)-1) .Cells(i, ii).Resize(, 2).Cut .Cells(i + (ii / 2) - 1, "B") Next ii End If Next i End With Application.ScreenUpdating = True End Sub 

Это делает это с массивами на новый лист

 Sub climatefreak() Dim lastrow& Dim ws As Worksheet Dim lastcolumn& Dim idx& Dim ClmIdx& Dim tws As Worksheet Dim i& Dim trw& Set tws = Sheets("Sheet3") Set ws = ActiveSheet With ws lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row For idx = 1 To lastrow Dim temparr lastcolumn = .Cells(idx, .Columns.Count).End(xlToLeft).Column temparr = Range(.Cells(idx, 1), .Cells(idx, lastcolumn)).Value For i = LBound(temparr, 2) + 1 To UBound(temparr, 2) Step 2 trw = tws.Range("A" & tws.Rows.Count).End(xlUp).Row + 1 tws.Cells(trw, 1) = temparr(UBound(temparr, 1), 1) tws.Cells(trw, 2).Resize(, 2) = Array(temparr(1, i), temparr(1, i + 1)) Next i Next idx End With End Sub 
Давайте будем гением компьютера.