遍历行和列Excel Macro VBA

Question

我在Excel工作表中有一列，其中包含以下格式的数据： aaa，bbbb，ccc，dd，eeee，...每个字符串都用逗号“，”分隔

我创建了一个宏，用于拆分A列中的数据，并将每个字符串分别插入到每一行的新单元格中，如屏幕截图所示。

现在，我想计算B列之后的已用单元格数量，并根据该数字在单独的行中重复B列中的值，然后将C，D，E等列中的下一个值添加到每一行...

最后，工作表2如下所示：

我创建了一个解决方案：

For i = 1 To 3

ActiveWorkbook.Sheets(2).Cells(i, 1).Value = ActiveWorkbook.Sheets(1).Range("B1").Value
ActiveWorkbook.Sheets(2).Cells(i, 2).Value = ActiveWorkbook.Sheets(1).Cells(1, i + 2).Value

Next i

但是，仅当列A仅具有一行时，它才起作用。 我已经尝试过使用Loops使用不同的逻辑，但是仍然无法获得正确的结果。 我有数百行，手动进行将很耗时。 请提出任何建议。 非常感谢你。

Answer 1

Sub ExtractParts()
    Dim wsSrc As Worksheet: Set wsSrc = Worksheets("Sheet1")
    Dim wsDest As Worksheet: Set wsDest = Worksheets("Sheet2")
    Dim LastRow As Long: LastRow = wsSrc.UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim LastCol As Long: LastCol = wsSrc.UsedRange.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Dim i As Long, j As Long, RowCounter As Long: RowCounter = 2

    With wsDest
        .Cells(1, 1) = "Order Number"
        .Cells(1, 2) = "Part Number"
        For i = 1 To LastRow
            For j = 3 To LastCol
                If wsSrc.Cells(i, j) <> "" Then
                    .Cells(RowCounter, 1) = wsSrc.Cells(i, 2)
                    .Cells(RowCounter, 2) = wsSrc.Cells(i, j)
                    RowCounter = RowCounter + 1
                End If
            Next j
        Next i
    End With
End Sub

Answer 2

您可以使用Dictionary方法

Sub main()
    Dim cell As Range
    Dim var As Variant

    With CreateObject("Scripting.Dictionary") '<--| instantiate a 'Dictionary' object
        For Each cell In Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").cells(Worksheets("Sheet1").Rows.Count, 1).End(xlUp)) '<-- loop through "Sheet1" column A cells from row 1 down to the last not empty one
            var = Split(cell.Value, ",") '<--| store current cell content into an array, whose first element will be the 'key' of the dictionary
            .item(var(0)) = Split(Replace(cell.Value, var(0) & ",", "", , 1), ",") '<--| update current 'key' dictionary item with the array of "remaining" values
        Next
        For Each var In .Keys '<--| loop through dictionary keys
            Set cell = Worksheets("Sheet2").cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(.item(var)) + 1) '<--| set "Sheet2" range to start writing the current key values from
            cell.Value = var '<--| write key
            cell.Offset(, 1).Value = Application.Transpose(.item(var)) '<--| write current key values
        Next
    End With '<--| release 'Dictionary' object
End Sub

Answer 3

这是一种方法

Sub x()

Dim r As Long, c As Long

Application.ScreenUpdating = False

With Sheets(1)
    For r = 1 To .Range("B" & Rows.Count).End(xlUp).Row
        c = .Cells(r, Columns.Count).End(xlToLeft).Column - 2
        .Cells(r, 2).Copy Sheets(2).Range("A" & Rows.Count).End(xlUp)(2).Resize(c)
        .Cells(r, 3).Resize(, c).Copy
        Sheets(2).Range("B" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True
    Next r
End With

Application.ScreenUpdating = True

End Sub

Answer 4

它已经被标记为已回答，但是我发现这个问题很有趣。 所以，这是我的贡献。 这段代码不需要将最初的内容分成多列，只需将一列用逗号分隔即可。

Dim rng As Range
Dim x As Variant
Dim i As Long
Dim offs As Long

offs = 1

Sheet2.Range("A1").Value = "Order Number"
Sheet2.Range("B1").Value = "Part Number"

For Each rng In Sheet1.Range("A:A")

    If Trim(rng.Value) = "" Then End

    x = Split(rng.Text, ",")

    For i = 1 To UBound(x)

        Sheet2.Range("A1").Offset(offs).Value = x(0)
        Sheet2.Range("B1").Offset(offs).Value = x(i)
        offs = offs + 1

    Next i

Next rng