动态重新格式化excel工作表

我有一张非常凌乱的excel表格，我正试图将其重新格式化为可读的格式。目前，它的结构是这样的（每个大的分离类似于一个新的单元）：

为了澄清这一点，每行每列的变量和值的数量各不相同，但是每个变量都有一个值。最终，我的最终目标是创建如下格式的内容：

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

其中标题字符串对其行中的每个Var和Var_值重复

我对VBA了解不多，所以我正在寻找实现这种格式的最佳途径的帮助。下面是我在psuedocode中的思考过程，我尽可能地将其格式化为VBA风格

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

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

---

这可以在新的工作表上使用数组

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

---

谢谢你，鲍勃！乍一看，它似乎起到了作用——我将在这里再深入研究一下，以了解到底发生了什么。我添加了一些评论，以帮助您理解这一点

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