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