[已解决]多次复制表格内容到想要的位置

雷神托尔100

如附件，将页签1中姓名和学历，复制到页签2中，按自己想要的次数复制，比如我想复制3次，就是复制3次，但不做排序，单纯的复制这一个范围；

最佳答案

月排行榜 / 总排行榜

我行我速2008

2022-8-23 10:51

Sub tt()
    Dim ar, br(), r%, k%
    Sheet2.[a1].CurrentRegion.Clear
    ar = Sheet1.[a1].CurrentRegion
    ReDim br(1 To UBound(ar), 1 To 2)
    For r = 1 To UBound(ar)
        br(r, 1) = ar(r, 3): br(r, 2) = ar(r, 5)
    Next r
    For k = 1 To Sheet1.Cells(3, 9)
        Sheet2.Cells(1 + UBound(ar) * (k - 1), 1).Resize(UBound(ar), 2) = br
    Next k
End Sub

跳转到最佳答案楼层

我行我速2008

Sub tt()
    Dim ar, br(), r%, k%
    Sheet2.[a1].CurrentRegion.Clear
    ar = Sheet1.[a1].CurrentRegion
    ReDim br(1 To UBound(ar), 1 To 2)
    For r = 1 To UBound(ar)
        br(r, 1) = ar(r, 3): br(r, 2) = ar(r, 5)
    Next r
    For k = 1 To Sheet1.Cells(3, 9)
        Sheet2.Cells(1 + UBound(ar) * (k - 1), 1).Resize(UBound(ar), 2) = br
    Next k
End Sub

哥儿-

Sub test()
    Dim arr, brr, i, num%
    arr = Sheet1.[a1].CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 2)
    For i = 2 To UBound(arr)
        brr(i - 1, 1) = arr(i, 3)
        brr(i - 1, 2) = arr(i, 5)
    Next i
    num = InputBox("请输入数次", "复制提示")
    With Sheet2
        .UsedRange.ClearContents
        .[a1:b1] = Array("姓名", "学历")
        If num = 1 Then
            .Cells(Rows.Count, 1).End(3).Offset(1).Resize(UBound(brr), 2) = brr
        Else
            For i = 1 To num
                .Cells(Rows.Count, 1).End(3).Offset(1).Resize(UBound(brr), 2) = brr
            Next i
        End If
    End With
End Sub