VBA拆分数据和填充数据请教大神写下代码

惠聲惠色

初始：Sheet1为数据源，Package Details和Package Information两表为空。需求：将Sheet1中A列和B列分别填充到Package Details中B列和D列。需要实现：1.Sheet1中A列的每行数据在Package Details中出现行数为Sheet1中C1的数值(比如30)，且在Package Details中D列当填充过来的数据信息每个的第一行填充数据和Sheet1中一致，其他行数(比如29)均填充为数字8；2.将Package Details的A列按B列数据进行依次顺序编号；3.将Package Details中A列编号填充到Package Information中A列，并将DEF三列全部填充为数字6。感谢大神！

3190496160

Sub 填充PackageDetails()
Dim ar As Variant
Dim i As Long
Dim arr()
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:b" & r)
    cs = .[c1]
    If cs = "" Then MsgBox "请输入填充行数！": End
    If Not IsNumeric(cs) Then MsgBox "请输入数值！": End
End With
ReDim arr(1 To UBound(ar) * cs, 1 To 4)
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" Then
        n = n + 1
        arr(n, 1) = n
        arr(n, 2) = ar(i, 1)
        arr(n, 4) = ar(i, 2)
        For s = 1 To cs - 1
            n = n + 1
            arr(n, 1) = n
            arr(n, 2) = ar(i, 1)
            arr(n, 4) = 8
        Next s
    End If
Next i
With Sheets("Package Details")
     rs = .Cells(Rows.Count, 1).End(xlUp).Row
     If rs > 1 Then .Range("a2:d" & rs) = Empty
     .[a2].Resize(n, 4) = arr
End With
MsgBox "ok!"
End Sub

3190496160

原表.rar (15.43 KB, 下载次数: 5)

2021-8-26 10:37 上传

点击文件名下载附件

3190496160

第一个，第二个问题解决了，第三个问题，非常简单，自己依样画葫芦吧

惠聲惠色

3190496160 发表于 2021-8-26 10:40
第一个，第二个问题解决了，第三个问题，非常简单，自己依样画葫芦吧

收到，感谢老师！