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)

"Ron Dean" wrote in message
. nl...
In using this, the code stops after coping & pasting the 1st line of the
2nd
last sheet.
Any ideas



"Ron Dean" wrote in message
. nl...
Fabulous, Bob.

Can you briefly explain what was wrong with my attempt

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


"Bob Phillips" wrote in message
...
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" wrote in message
. nl...
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