Question

我有一个包含一列数字的电子表格。

对于参考列中的每个值，我需要使用to excel在相邻列中生成一行数字，其值从数字1开始，逐渐增加1并在达到参考值时结束。然后需要对参考列中的下一个值重复此操作，依此类推，继续在相邻列中展开。

下面是一个包含3个值的参考列的示例以及我手动相邻的值。有些人可以帮我写一下VBA中的功能，这样我就不需要手动执行此操作了

感谢先进的帮助。

Answer 1

Sub main()
    Dim cell As Range, i As Long
    For Each cell In Range("I2", Cells(Rows.Count, "I").End(xlUp))
        For i = 1 To cell.Value
            Cells(Rows.Count, "J").End(xlUp).Offset(1).Value = i
        Next
    Next
End Sub

Answer 2

较大的分组系列将受益于数组。

sub main()
    dim i as long, j as long, k as long, vals as variant

    redim vals(1 to application.sum(range(cells(2, "i"), cells(rows.count, "i").end(xlup))), 1 to 1)

    for i=2 to cells(rows.count, "i").end(xlup).row
        for j=1 to cells(i, "i").value2
            k=k+1
            vals(k, 1) = j
        next j
    next i

    cells(2, "j").resize(ubound(vals, 1), ubound(vals, 2)) = vals
end sub

Answer 3

或使用数组

Option Explicit

Sub test()

    Dim arr(), i As Long, j As Long, output As String

    With ThisWorkbook.Worksheets("Sheet1")
        arr = .Range("I2", .Cells(.Rows.Count, "I").End(xlUp)).Value
        For i = LBound(arr, 1) To UBound(arr, 1)
            j = 0
            Do While j < arr(i, 1)
                j = j + 1
                output = output & CStr(j) & ","
            Loop
        Next i
        .Range("J2").Resize(UBound(Split(output, ",")), 1) = Application.WorksheetFunction.Transpose(Split(output, ","))
    End With
End Sub

Answer 4

这不允许您超越最后一行Excel行

Option Explicit

Public Sub ExpandReferenceNumbers()
    Const REF_COL = 9 'I
    Dim arr As Variant, lr As Long, i As Long, j As Long, k As Long
    Dim maxRows As Long, maxVal As Long, maxXLRows As Long

    maxXLRows = Rows.Count
    lr = Sheet1.Cells(maxXLRows, REF_COL).End(xlUp).Row

    arr = Sheet1.Range(Sheet1.Cells(2, REF_COL), Sheet1.Cells(lr, REF_COL))
    For i = 1 To lr - 1
        maxRows = maxRows + arr(i, 1)
    Next
    If maxRows > maxXLRows Then maxRows = maxXLRows - 2

    arr = Sheet1.Range(Sheet1.Cells(2, REF_COL), Sheet1.Cells(maxRows + 1, REF_COL + 1))
    k = 1
    For i = 1 To lr
        For j = 1 To arr(i, 1)
            If k + j - 1 > maxRows Then Exit For
            arr(k + j - 1, 2) = j
        Next
        k = k + arr(i, 1)
    Next
    Sheet1.Range(Sheet1.Cells(2, REF_COL), Sheet1.Cells(maxRows + 1, REF_COL + 1)) = arr
End Sub

结果

根据单元格中的数字将单个单元格扩展为多行 - EXCEL

4 个答案: