Excel VBA 复制多个范围并粘贴到另一个工作表，没有空行

Question

在研究和测试之后，简单地将 Excel 中的一系列数据复制到一张工作表上，只保留这些值并将它们粘贴到另一个工作表中似乎相当基本。 我想要实现的是拥有一个每周都使用的时间卡模板。 填写完一周的信息后，我单击软盘符号复制所有数据并粘贴到下一个可用行之后的 ARCHIVE 表中。 然后另一个脚本附加到回收站符号，清除条目，以便为下周做好准备。 哦，复印机符号也只是创建一个可以归档或发送到工资单的副本。 但是，我遇到了一个问题，因为我正在复制多个范围，并且它们并不总是在每个范围的每一行中都有值。 （有些日子我只做一份工作，其他日子所有行都可能有值）结果似乎也显示了空白行。 我想要一个很好的干净的所有数据的连续存档，而不必删除空白行。 我认为代码的“SkipBlanks”部分会消除这种情况，但事实并非如此。

可以更改 VBA 以消除空白吗？

Sub SaveToArchive()

response = MsgBox("Are You Sure?", vbYesNo)

If response = vbNo Then
MsgBox ("Goodbye!")
Exit Sub

End If

Sheets("MAIN").Range("A6:K11,A14:K19,A22:K27,A30:K35,A38:K43,A46:K50").Copy

Sheets("ARCHIVE").Select
Range("A65536").End(xlUp)(2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("A1").Select

Sheets("MAIN").Select
Range("B3").Select

SendKeys ("{ESC}")



End Sub

Answer 1

“ SkipBlanks ”用于当您有要复制的范围以及粘贴到新位置时，您不想让以前的值被空白/空数据覆盖。 但是，它不会从您的范围中排除任何单元格。 因此，您仍然会得到“空”行。

1A - 您可以像这样在 VBA 中构建范围：

Range("S73:S128") -> Range(Cells(S73), Cells(S128)) -> 
Range(Cells(row number, column number), Cells(row number, column number)) -> 
Range(Cells(73, 19), Cells(128, 19))

2A - 我们可以像这样参考不同的工作簿：

Dim Wkb As Workbook
Set Wkb = ThisWorkbook
Dim MainSheet As Worksheet
Set MainSheet = Wkb.Worksheets("MAIN")
Dim ArchiveSheet As Worksheet
Set ArchiveSheet = Wkb.Worksheets("ARCHIVE")

如果我们将这两个 1A 和 2A 结合起来，我们可以参考同一工作簿中的不同工作表。

MainSheet.Range(MainSheet.Cells(73, 19), MainSheet.Cells(128, 19)) -> 是工作表“Main”的范围“ S73:S128 ”

存档也可以这样做： ArchiveSheet.Range(ArchiveSheet.Cells(73, 19), ArchiveSheet.Cells(128, 19)) -> is range " S73:S128 " for the worksheet "Archive"

当我们想要跨工作表复制和粘贴时，此方法很有用。

---

最后一行可以重新定义为：

Range("A65536").End(xlUp)(2).Select --> Archivelrow = Worksheets("ARCHIVE").Cells(Rows.Count, 2).End(xlUp).Row ，其中 lrow 将是变量我们可以用它来引用最后一行。

---

3A - 我们可以遍历 Column 中的每个单元格，并使用“ FOR循环”仅选择我们感兴趣的单元格。 这将使您的范围动态化。 如果添加或删除行，我们只会循环更多或更少的行。

For i = 6 To 51 'This would tell us, loop from row 6 to 51.
'For each loop, do something
Cells(i,1).Value ' This will take the value for Cell in Column A, at row i. Remember point 1A, where we wrote cells!
Next i

下一步，我们不想复制所有内容。在 A 列中，我们不想复制带有标题的单元格，例如：“日期”、“星期一”等。

4A - If 语句将在这里帮助我们。 我们可以设置一个条件（一个 TRUE/FALSE 语句）

If Cells(i,1).Value = "Blue" Or Cells(i,1).Value = "Red" Then
'"Do something" if the current cell in loop has value "Blue" or "Red"
Else
'"Don't do anything" if the current cell in loop don't contain value "Blue" or "Red"
End if

如果我们将这两者结合起来，3A & 4A，我们就可以遍历每个单元格，并且只有在单元格值满足某个条件时才执行。

在您的情况下，我们将有：

For i = 6 To Mainlrow 'loop from row 6 to last row in column A and F
    ' Check if Column F = TOTAL, Check if Column A = DATE, Check if Column B has empty cells, Check Column A for last row that contain word TOTAL
    If MainSheet.Cells(i, 6).Value = "TOTAL" Or MainSheet.Cells(i, 1).Value = "DATE" Or _
        MainSheet.Cells(i, 2).Value = "" Or MainSheet.Cells(i, 1).Value Like "*TOTAL*" Then
        'Do nothing
    Else
        MainSheet.Range(MainSheet.Cells(i, 1), MainSheet.Cells(i, 11)).Copy _
        ArchiveSheet.Range(ArchiveSheet.Cells(Archivelrow, 1), ArchiveSheet.Cells(Archivelrow, 11)) 'Copy range from Sheet "Main" to Sheet "Archive"
        Application.CutCopyMode = False 'Remove selection

        ArchiveSheet.Range(ArchiveSheet.Cells(Archivelrow, 1), ArchiveSheet.Cells(Archivelrow, 11)).Columns.AutoFit 'Autofit columns
    Archivelrow = Archivelrow + 1 'Add one to lastrow
    End If
Next i

这将使您的完整代码（更新）：

Sub SaveToArchive2()

Dim response As String

response = MsgBox("Are You Sure?", vbYesNo)

If response = vbNo Then
    MsgBox ("Goodbye!")
    Exit Sub
End If

Dim i As Long
Dim Mainlrow As Long
Dim Archivelrow As Long
Dim Wkb As Workbook
Set Wkb = ThisWorkbook
Dim MainSheet As Worksheet
Set MainSheet = Wkb.Worksheets("MAIN")
Dim ArchiveSheet As Worksheet
Set ArchiveSheet = Wkb.Worksheets("ARCHIVE")

Mainlrow = MainSheet.Cells(Rows.Count, 7).End(xlUp).Row 'take the last row by looking in column G
Archivelrow = ArchiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 'take the last row by looking in column F

For i = 6 To Mainlrow 'loop from row 6 to last row in column A and F
    ' Check if Column F = TOTAL, Check if Column A = DATE, Check if Column B has empty cells, Check Column A for last row that contain word TOTAL
    If MainSheet.Cells(i, 6).Value = "TOTAL" Or MainSheet.Cells(i, 1).Value = "DATE" Or _
        MainSheet.Cells(i, 2).Value = "" Or MainSheet.Cells(i, 1).Value Like "*TOTAL*" Then
        'Do nothing
    Else
        With MainSheet.Range(MainSheet.Cells(i, 1), MainSheet.Cells(i, 11))
            ArchiveSheet.Range(ArchiveSheet.Cells(Archivelrow, 1), ArchiveSheet.Cells(Archivelrow, 11)).Value = .Value 'Copy range from Sheet "Main" to Sheet "Archive"
        End With
        Application.CutCopyMode = False 'Remove selection
        ArchiveSheet.Range(ArchiveSheet.Cells(Archivelrow, 1), ArchiveSheet.Cells(Archivelrow, 11)).Columns.AutoFit 'Autofit columns
    Archivelrow = Archivelrow + 1 'Add one to lastrow
    End If
Next i

    SendKeys ("{ESC}")

End Sub

您想复制相同的行，您还想从...清除数据，我们几乎已经完成了上面的代码。 我们不是复制，而是替换它并说： Range(xy).ClearContents - 清除此范围的单元格内容。 由于您在 A 列中有公式，我们只清除 B 列到 K 列的单元格

所以代码将是：

Sub ClearContentMain()
'link this to recycling bin symbol
Dim i As Long
Dim MainClearlrow As Long
Dim Wkb As Workbook
Set Wkb = ThisWorkbook
Dim MainSheet As Worksheet
Set MainSheet = Wkb.Worksheets("MAIN")
Dim ArchiveSheet As Worksheet
Set ArchiveSheet = Wkb.Worksheets("ARCHIVE")

MainClearlrow = MainSheet.Cells(Rows.Count, 7).End(xlUp).Row 'take the last row by looking in column G

For i = 6 To MainClearlrow 'loop from row 6 to last row in column A and F
    ' Check if Column F = TOTAL, Check if Column A = DATE, Check if Column B has empty cells, Check Column A for last row that contain word TOTAL
    If MainSheet.Cells(i, 6).Value = "TOTAL" Or MainSheet.Cells(i, 1).Value = "DATE" Or _
        MainSheet.Cells(i, 2).Value = "" Or MainSheet.Cells(i, 1).Value Like "*TOTAL*" Then
    'Do nothing
    Else
        MainSheet.Range(MainSheet.Cells(i, 2), MainSheet.Cells(i, 11)).ClearContents 'clear contents for only values that has values filled in Column A. except headers
    End If
Next i

End Sub