dynamic地重新格式化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 

为了澄清，每列的variables和值的数量是不同的，但每个variables都有一个值。 最终，我的最终目标是创build一些格式如下的东西：

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

标题string在其行中的每个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 

Answer 1

这段代码应该这样做（注意，它假定没有标题行）

 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 

Answer 2

这将它与数组添加到新的工作表

 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