我想轻松地将表数据转换为其他表格式,而无需使用任何数据透视表。我想用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
答案 0 :(得分:0)
我认为将表值移动到新表中比重新输入表更容易,这是您的代码所尝试的。
这会将结果放置在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
答案 1 :(得分:0)
以下代码将实现您的预期目标,它将遍历从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