循环浏览Excel宏VBA中的行和列

我在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只有一行时工作。我尝试了使用循环的不同逻辑，但仍然没有得到正确的结果。我有成百上千行，手工操作很费时。有什么建议吗。非常感谢。

这里有一种方法

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

Sub-ExtractParts（）
将wsSrc标注为工作表：设置wsSrc=工作表（“表1”）
将wsDest设置为工作表：设置wsDest=工作表（“表2”）
调整LastRow的长度：LastRow=wsSrc.UsedRange.Find（“*”，SearchOrder:=xlByRows，SearchDirection:=xlPrevious）。行
将LastCol的长度设置为：LastCol=wsSrc.UsedRange.Find（“*”，SearchOrder:=xlByColumns，SearchDirection:=xlPrevious）。Column
尺寸i等于长，j等于长，行计数器等于长：行计数器=2
用wsDest
.单元格（1，1）=“订单号”
.单元格（1，2）=“零件号”
对于i=1到最后一行
对于j=3到LastCol
如果wsSrc.Cells（i，j）“，则
.Cells（行计数器，1）=wsSrc.Cells（i，2）
.Cells（行计数器，2）=wsSrc.Cells（i，j）
行计数器=行计数器+1
如果结束
下一个j
接下来我
以
端接头

您可以使用

字典

方法

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

Sub-main（）
暗淡单元格作为范围
作为变量的Dim-var
使用CreateObject（“Scripting.Dictionary”）它已经标记为已回答，但我发现这个问题很有趣。这是我的贡献。此代码不需要初始拆分为多个列，只需要一个包含逗号分隔数据的列

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

非常感谢你。非常感谢，非常感谢。非常感谢正如您可能猜到的，这段代码完成了所有过程：从sheet1列A中的数据到Sheet2列A和B中的数据写入。不在sheet1中写入任何其他内容，非常感谢。非常感谢非常感谢，非常有帮助。
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