从 sheet1 到 sheet2 逐行复制，中间有空行

Question

我正在尝试将行从 sheet1（行数最多可达 700）复制到 sheet2。

Sheet1 A 列是文本，B、C 和 D 有公式。

在 sheet2 上，每行之间应该有五个空行。粘贴应从第 17 行（接下来的 22 行等）开始。

我查了谷歌，但不知道如何修改我找到的代码。

Answer 1

给你，不知道这是否是你想要的。 A 列仅是字符串，B 到 D 列包含公式。您提到要在其间留下五个空行，但我看到您的描述还提到从第 17 行开始，然后下一个应该从第 22 行开始，即四个空行。您可以通过将偏移量从 4 更改为 5 来更改空行数。

Sub copy_to_sheet2()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim count_1 As Integer
Dim count_2 As Integer
Dim offset As Integer
Dim last_row As Long

'your workbook / sheets name
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")

'get total rows of sheet 1
last_row = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row
count_1 = 1 'sheet 1 counter
count_2 = 17 'sheet 2 counter
offset = 0 'offset / empty rows default value

    'loop sheet 1 from 1st row to last row
    For i = 1 To last_row

        If i = 2 Then
            offset = 4 '2nd loop change offset to 4
        ElseIf i > 2 Then
            offset = offset + 4 'subsequent loop offset + 4
        End If

        'copy sheet 1 column A to D row by row & paste values to sheet 2 with offset row by row
        ws1.Range("A" & count_1 & ":" & "D" & count_1).SpecialCells(xlCellTypeVisible).Copy
        ws2.Range("A" & count_2 + offset).PasteSpecial xlPasteValues

        'add counter
        count_1 = count_1 + 1
        count_2 = count_2 + 1

    Next i

End Sub