求助！VBA重复复制粘贴！

272956015

就和图一一样，把表1的名称复制到表2中，重复复制规定的行数，并且在第二列填充开始到结束的对应值。求教VBA的编码

3190496160

一个很基础额问题，但是，没有附加，不想费神模拟附件

272956015

3190496160 发表于 2022-1-3 10:31
一个很基础额问题，但是，没有附加，不想费神模拟附件

大神，上传附件了，还望帮助

3190496160

Sub 拷贝()
Dim ar As Variant
Dim arr()
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:d" & r)
End With
ReDim arr(1 To UBound(ar) * 1000, 1 To 2)
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" And Trim(ar(i, 3)) <> "" And Trim(ar(i, 4)) <> "" Then
        ks = ar(i, 2)
        js = ar(i, 3)
        For s = ks To js
            n = n + 1
            arr(n, 1) = ar(i, 1)
            arr(n, 2) = s
        Next s
    End If
Next i
With Sheets("sheet2")
    .Columns("a:b") = mpty
    .[a1].Resize(n, 2) = arr
End With
            
End Sub

3190496160

工作簿1.rar (15.04 KB, 下载次数: 4)

2022-1-3 16:57 上传

点击文件名下载附件

272956015

3190496160 发表于 2022-1-3 16:57

多谢大神！！！