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

Question

After researching and testing, it seems fairly basic to simply copy a range of data in Excel on one sheet, keep just the values and paste them into another. What I'm trying to achieve is to have a time card template that is used week after week. After filling out the week's info I click the diskette symbol copying all the data and pasting into the ARCHIVE sheet after the next available row. Then another script is attached to the recycling bin symbol the clears the entries so it's ready for the next week. Oh, also the Copy machine symbol just creates a copy that can be filed away or sent to payroll. However, I'm running into a problem because I'm copying multiple ranges and they won't always have values in EVERY row of each range. (some days I'm just on one job, other days all the rows may have values) It seems the results show the blank rows as well. I would like a nice clean continuous archive of all the data without having to delete blank rows. I thought that the "SkipBlanks" part of the code would eliminate that, but not so.

Could the VBA be changed to eliminate the blanks?

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 " is used when you have a range you want to copy and and when you paste to a new place, you don't want to get your previous values overwritten with blank/empty data. However, it will not exclude any cells from your range. Therefore you will still get "empty" rows.

1A - You can build ranges in VBA like this:

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 - We can refer to different workbooks like this:

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")

If we combine these two, 1A & 2A, we can refer to different worksheets in the same workbook.

MainSheet.Range(MainSheet.Cells(73, 19), MainSheet.Cells(128, 19)) -> is range " S73:S128 " for the worksheet "Main"

And the same can be done for Archive: ArchiveSheet.Range(ArchiveSheet.Cells(73, 19), ArchiveSheet.Cells(128, 19)) -> is range " S73:S128 " for the worksheet "Archive"

This method is useful when we want to copy and paste across worksheet.

---

Last row can be redefined as:

Range("A65536").End(xlUp)(2).Select --> Archivelrow = Worksheets("ARCHIVE").Cells(Rows.Count, 2).End(xlUp).Row , where lrow will be the variable which we can use to refer to the last row.

---

3A - We can loop through each cell in a Column and only pick cells we are interesting in by using " FOR loop". This will make your range dynamic. If rows are added or deleted, we only loop through more or less rows.

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

Next step, we don't want to copy everything.. In Column A, we don't want to copy cells with the Headers such as: "Date", "Monday" etc..

4A - If statement will help us here. We can set a condition (a TRUE/FALSE statement)

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

If we combine these two, 3A & 4A, we can loop through each cell and only execute if the cell value meets a certain condition.

In your case, we will have:

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

This will make your complete code to ( updated ):

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

The same rows you want to copy, you also want to clear data from... and we almost have the code done from above. Instead of copying, we replace it and say: Range(xy).ClearContents - Clear cell content for this range. Since you have formulas in column A, we only clear cells from Column B to Column K

So the code will be:

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