求修改代码

lagos

粘贴时的定位，向右粘贴，每次粘贴间隔一列或两列，详情请见代码 求修改定位代码.rar (11.82 KB, 下载次数: 7)

2023-5-28 17:29 上传

点击文件名下载附件

shiruiqiang

gwjkkkkk

Sub test()
    Dim Rng As Range, n&
    For i = 1 To 3
        Set Rng = Sheets(i).[E2:F11]
        n = (i - 1) * 4 + 1
        Rng.Copy Cells(2, n)
    Next i
End Sub

gwjkkkkk

请参考。。。

海好呀

Sub 复制粘贴()
Set sh = Sheets("sheet4")
x = 1
For Each sht In Sheets
      If sh.Name <> "sheet4" Then
            sht.Range("e2").CurrentRegion.Copy sh.Cells(2, x)
            x = x + 4
       End If
Next
End Sub

rakehell78

Sub test()
    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim i As Long, j As Long
Set srcSheet = ThisWorkbook.Sheets("Sheet1")
Set destSheet = ThisWorkbook.Sheets("Sheet2")
For i = 1 To 3
    Set srcRng = srcSheet.Range("E2:F11")
    Set destRng = destSheet.Cells(2, (i - 1) * 4 + 1)
    For j = 1 To srcRng.Rows.Count
        srcRng.Rows(j).Copy destRng
        Set destRng = destRng.Offset(1, 0)
    Next j
Next i