Question

我想轻松地将表数据转换为其他表格式，而无需使用任何数据透视表。我想用excel VBA做到这一点，所以只要按一下按钮，我就能得到想要的结果，但是我对如何编写此代码还不了解。任何帮助表示赞赏。

E到Q列包含大小（36到48）

请参见下面的屏幕截图，其中显示了以下输入数据和输出表的示例：

我有这段代码，但还不能完全满足我的要求：

Sub TESTexample()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim lastcol As Integer
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Dim r As Integer
Dim c As Integer
For r = lastrow To 2 Step -1
For c = lastcol To 3 Step -1If Cells(r, c) <> "" Then
Rows(r + 1).Insert
Cells(r + 1, 1) = Cells(r, 1)
Cells(r + 1, 2) = Cells(r, c)
Cells(r, c).Clear
Else: Rows(r).Delete
End If
Next
Next
End Sub

编辑：我找到了解决方案，以下代码有效：

Sub Button1_Click()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim lastcol As Integer
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column

Dim r As Integer
Dim c As Integer

For r = lastrow To 2 Step -1

    For c = lastcol To 7 Step -1
        If Cells(r, c) <> "" Then
            Rows(r + 5).Insert
            Cells(r + 5, 1) = Cells(1, c)
            Cells(r + 5, 2) = Cells(r, 1)
            Cells(r + 5, 3) = Cells(r, 2)
            Cells(r + 5, 4) = Cells(r, 3)
            Cells(r + 5, 5) = Cells(r, 5)
            Cells(r + 5, 6) = Cells(r, c)

            Cells(r, c).Clear
        'Else: Rows(r).Delete
        End If
    Next

Next
End Sub

亲切的问候， PJ

Answer 1

我认为将表值移动到新表中比重新输入表更容易，这是您的代码所尝试的。

这会将结果放置在Sheet2上，并假设输入表位于Sheet1上，并且您的数据从第3行开始，因此您可能需要修改所有这些内容。

Sub x()

Dim r As Long, r1 As Range, r2 As Range, ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Worksheets("Sheet1") 'input
Set ws2 = Worksheets("Sheet2") 'output

ws2.Range("A1:F1").Value = Array("Size", "Article", "Model", "Color", "Amount", "Location")

With ws1
    For r = 3 To .Range("A" & Rows.Count).End(xlUp).Row
        If .Cells(r, "D") > 0 Then 'tot
            Set r1 = Range(.Cells(r, "E"), .Cells(r, "Q")).SpecialCells(xlCellTypeConstants)
            For Each r2 In r1
                ws2.Range("A" & Rows.Count).End(xlUp)(2).Value = .Cells(2, r2.Column).Value 'size
                ws2.Range("B" & Rows.Count).End(xlUp)(2).Resize(, 3).Value = .Cells(r, 1).Resize(, 3).Value 'article/model/colour
                ws2.Range("E" & Rows.Count).End(xlUp)(2).Value = r2.Value ' amount
                ws2.Range("F" & Rows.Count).End(xlUp)(2).Value = .Cells(r, "R").Value 'location
            Next r2
        End If
    Next r
End With

End Sub

Answer 2

以下代码将实现您的预期目标，它将遍历从E到Q的范围，如果单元格不为空，它将在新表中写入行详细信息：

Sub Transform()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
'get the last row and last column with data
ws.Range(ws.Cells(LastRow + 2, 1), ws.Cells(LastRow + 2, 6)).Value = Array("Size", "Article", "Model", "Color", "Amount", "Location")
'insert new headers below the table

Set Rng = ws.Range(ws.Cells(2, 5), ws.Cells(LastRow, LastCol - 1))
For Each c In Rng
    If c.Value <> "" Then
        NextRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
        ws.Cells(NextRow, 1).Value = ws.Cells(1, c.Column).Value
        ws.Cells(NextRow, 2).Value = ws.Cells(c.Row, 1).Value
        ws.Cells(NextRow, 3).Value = ws.Cells(c.Row, 2).Value
        ws.Cells(NextRow, 4).Value = ws.Cells(c.Row, 3).Value
        ws.Cells(NextRow, 5).Value = c.Value
        ws.Cells(NextRow, 6).Value = ws.Cells(c.Row, LastCol).Value
    End If
Next c
End Sub

使用Excel VBA转换表数据

2 个答案: