Question

我有一个非常凌乱的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

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

动态重新格式化Excel工作表

2 个答案: