如果列K：R全部包含空白VBA Excel，则删除行

Question

Bit of a background: I'm trying to copy a table from "Create Form" N2:AE14

Set r = Sheets("Create Form").Range("COPYTABLEB")
Selection.Copy

Set dest = Sheets("Sample Data").Range("B1").End(xlDown).Offset(1, 0)     
r.Copy
dest.PasteSpecial Paste:=xlPasteValues

I want it to copy only the cells that have values and not blanks but unfortunately it's picking up the formulas and pasting them as blanks. So when I go to paste the next section in, it sees the blanks as data.

So instead I'm trying to figure out a way of deleting an entire Row in "Sample Data" if Columns K:R all contain blanks once its been copied across.

I currently have a loop that does it for column B being blank but it takes far too long.

Lastrow = Range("B" & Rows.Count).End(xlUp).Row
MsgBox (Lastrow)
For i = Lastrow To 2 Step -1
If Trim(Range("B" & i).Value) = "" And Trim(Range("B" & i).Value) = "" Then
Range("B" & i).EntireRow.Select
Selection.Delete

End If

Next i

Could someone please help me either:
a.) copy and paste the values across minus all the blanks
b.) or help me with a quicker way of deleting the rows?

Answer 1

assuming

• you want to delete

"an entire Row in "Sample Data" if Columns K:R all contain blanks"

you could try this:

Sub CopyValuesAndDeleteRowsWithBlankKRColumns()
    Dim pasteArea As Range
    Dim iRow As Long

    With Sheets("Create Form").Range("COPYTABLEB")
        Set pasteArea = Sheets("Sample Data").Range("B" & Rows.count).End(xlUp).Offset(1, 0).Resize(.Rows.count, .Columns.count)
        pasteArea.Value = .Value
    End With
    With Intersect(pasteArea, Sheets("Sample Data").Range("K:R"))
        For iRow = .Rows.count To 1 Step -1
            MsgBox WorksheetFunction.CountBlank(.Rows(iRow)) & " - " & WorksheetFunction.CountBlank(.Rows(iRow)) Mod 8
            If WorksheetFunction.CountBlank(.Rows(iRow)) Mod 8 = 0 Then .Rows(iRow).EntireRow.Delete
        Next
    End With
End Sub