[已解决]怎样实现按数拆行？

不信这样还重名

如上图所示，怎么按照姓名后面对应的次数增加新的行呢，新手上路，录了个宏只能勉强看懂，不知是道怎么改成一个动态的，求大神指导下。

最佳答案

月排行榜 / 总排行榜

sam-wang

2022-1-20 08:12

請測試看看，謝謝
Sub test()
Dim Arr, Brr(1 To 10000, 1 To 2), i&, i2%
Arr = Sheets(1).[a1].CurrentRegion
For i = 2 To UBound(Arr): For i2 = 1 To Arr(i, 2)
    n = n + 1: Brr(n, 1) = Arr(i, 1): Brr(n, 2) = 1
Next i2: Next i
Sheets(2).[a2:a10000] = ""
Sheets(2).[a2].Resize(n, 2) = Brr
End Sub

跳转到最佳答案楼层

wanao2008

但愿能帮助到你！
Sub byWanao()
    Dim i%, j%, endRow%, endNum%, endRow2%
    endRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Sheet2.Range("A2:B200").ClearContents
    For i = 2 To endRow
        endNum = Sheet1.Cells(i, 2)
        For j = 1 To endNum
            endRow2 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1
            Sheet2.Cells(endRow2, 1) = Sheet1.Cells(i, 1)
            Sheet2.Cells(endRow2, 2) = 1
        Next
    Next
End Sub

sam-wang

請測試看看，謝謝
Sub test()
Dim Arr, Brr(1 To 10000, 1 To 2), i&, i2%
Arr = Sheets(1).[a1].CurrentRegion
For i = 2 To UBound(Arr): For i2 = 1 To Arr(i, 2)
    n = n + 1: Brr(n, 1) = Arr(i, 1): Brr(n, 2) = 1
Next i2: Next i
Sheets(2).[a2:a10000] = ""
Sheets(2).[a2].Resize(n, 2) = Brr
End Sub

Yunyun123

Public Sub RowInsert()
Dim i As Integer
Dim countRow As Integer
Dim RowNum As Integer
Range("a1").CurrentRegion.Select
countRow = Selection.Rows.Count
i = 2
Do Until Cells(i, 2) = ""
RowNum = Cells(i, 2)
If RowNum <> 1 Then
Cells(i + 1, 1).EntireRow.Select
Selection.Resize(RowNum - 1).Insert
Range(Cells(i + 1, 1), Cells(i + RowNum - 1, 1)) = Cells(i, 1)
Range(Cells(i, 2), Cells(i + RowNum - 1, 2)) = 1
i = i + RowNum
Else
i = i + 1
End If
Loop
End Sub

hcm19522

D2{=OFFSET(A$1,SMALL(IF(B$2:B$5>=COLUMN(A:Z),ROW($1:$4),99),ROW(A1)),)&""

不信这样还重名

wanao2008 发表于 2022-1-20 06:03
但愿能帮助到你！
Sub byWanao()
    Dim i%, j%, endRow%, endNum%, endRow2%

十分感谢回复，可以实现目标效果，对我理解循环很有帮助。二楼用的方法速度要更快些，最佳答案就给他啦。其实你的答案对我而言倒要好理解些。

不信这样还重名

Yunyun123 发表于 2022-1-20 09:02
Public Sub RowInsert()
Dim i As Integer
Dim countRow As Integer

这个也可以实现目标效果，又学到了一种思路，哈哈，感谢回复。

不信这样还重名

hcm19522 发表于 2022-1-20 10:54
D2{=OFFSET(A$1,SMALL(IF(B$2:B$5>=COLUMN(A:Z),ROW($1:$4),99),ROW(A1)),)&""

函数也可以解，高手，学习了。

wanao2008

不信这样还重名 发表于 2022-1-20 10:58
十分感谢回复，可以实现目标效果，对我理解循环很有帮助。二楼用的方法速度要更快些，最佳答案就给他啦。 ...

其实我用你的问题录制了一段视频：
全实例学VBA-41-怎样实现按数拆行 - wanao.梦田的视频 - 知乎https://www.zhihu.com/zvideo/1467382490628931584

大灰狼1976

超过255字符嗝屁：

1. Sub test()
   
2. Dim arr, i&, s$
   
3. arr = [a1].CurrentRegion
   
4. For i = 2 To UBound(arr)
   
5.   s = s & Application.Rept(";""" & arr(i, 1) & """," & 1, arr(i, 2))
   
6. Next i
   
7. arr = Evaluate("{" & Mid(s, 2) & "}")
   
8. [a2].Resize(UBound(arr), 2) = arr
   
9. End Sub

复制代码