Paste blank cell row loop

[Ron Dean]

I am attempting to copy and paste to a new sheet any rows in each worksheet
which have a blank cell in column K.
The attached code does not loop through the worksheets but sticks in Sheet
1.

Can anyone help a grey haired, frustrated VBA dunce


Sub Non_Payment()

' ********* Header
Sheet1.Activate
Rows("1:1").Select
Selection.Copy

' ******* Make new sheet
Dim SHT As Object
On Error Resume Next
Set SHT = Sheets("NotPaid")
On Error GoTo 0
If SHT Is Nothing Then
Set SHT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
SHT.Name = "NotPaid"
End If

'**** paste header
SHT.Activate
Rows("1:1").Select
ActiveSheet.Paste

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
' If WS.Name <> "NotPaid" Then

Dim Rng As Range
Dim i As Range
Set Rng = Range("K2", Range("K" & Rows.Count).End(xlUp))
Dim r As Integer
r = 2
For Each i In Rng
If i = "" Then
i.EntireRow.Copy
Sheets("NotPaid").Range("K" & Rows.Count).End(xlUp)(r). _
EntireRow.PasteSpecial
r = r + 1
ActiveCell.Offset(1, 0).Select
End If
Next i

' End If
Next WS


Rows("1:1").Select


End Sub

 

[Bob Phillips]

I haven't tested it, but give this a try

Sub Non_Payment()

' ********* Header
Sheet1.Activate
Rows("1:1").Select
Selection.Copy

' ******* Make new sheet
Dim SHT As Object
On Error Resume Next
Set SHT = Sheets("NotPaid")
On Error GoTo 0
If SHT Is Nothing Then
Set SHT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
SHT.Name = "NotPaid"
End If

'**** paste header
SHT.Activate
Rows("1:1").Select
ActiveSheet.Paste

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
' If WS.Name <> "NotPaid" Then

Dim Rng As Range
Dim i As Range
Set Rng = WS.Range("K2", WS.Range("K" & ws.Rows.Count).End(xlUp))
Dim r As Integer
r = 2
For Each i In Rng
If i = "" Then
i.EntireRow.Copy
SHT.Range("K" & Rows.Count).End(xlUp)(r). _
EntireRow.PasteSpecial
r = r + 1
End If
Next i

' End If
Next WS

Rows("1:1").Select

End Sub

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Ron Dean]

Fabulous, Bob.

Can you briefly explain what was wrong with my attempt

Rob
+++++++++++++++++++++

 

[Bob Phillips]

Essentially you were not using the WS object that you so carefully primed.
This code

Set Rng = Range("K2", Range("K" & Rows.Count).End(xlUp))

I changed to

Set Rng = WS.Range("K2", WS.Range("K" & ws.Rows.Count).End(xlUp))

I also changed this

For Each i In Rng
If i = "" Then
i.EntireRow.Copy
Sheets("NotPaid").Range("K" & Rows.Count).End(xlUp)(r). _
EntireRow.PasteSpecial
r = r + 1
ActiveCell.Offset(1, 0).Select
End If

as it didn't ned the cell selecting, and could use the SHT you declared
earlier

For Each i In Rng
If i = "" Then
i.EntireRow.Copy
SHT.Range("K" & Rows.Count).End(xlUp)(r). _
EntireRow.PasteSpecial
r = r + 1
End If


--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[Ron Dean]

In using this, the code stops after coping & pasting the 1st line of the 2nd
last sheet.
Any ideas

 

[Bob Phillips]

I have just tested it Ron, and it ran fine for me. Any more details?

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)