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" <[email protected]> wrote in message
news:[email protected]...
> 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
>
>

[Ron Dean]

Fabulous, Bob.

Can you briefly explain what was wrong with my attempt

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


"Bob Phillips" <[email protected]> wrote in message
news:[email protected]...
>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" <[email protected]> wrote in message
> news:[email protected]...
>> 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]

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" <[email protected]> wrote in message
news:[email protected]...
> Fabulous, Bob.
>
> Can you briefly explain what was wrong with my attempt
>
> Rob
> +++++++++++++++++++++
>
>
> "Bob Phillips" <[email protected]> wrote in message
> news:[email protected]...
> >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" <[email protected]> wrote in message
> > news:[email protected]...
> >> 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
> >>
> >>
> >
> >
>
>

[Ron Dean]

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



"Ron Dean" <[email protected]> wrote in message
news:[email protected]...
> Fabulous, Bob.
>
> Can you briefly explain what was wrong with my attempt
>
> Rob
> +++++++++++++++++++++
>
>
> "Bob Phillips" <[email protected]> wrote in message
> news:[email protected]...
>>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" <[email protected]> wrote in message
>> news:[email protected]...
>>> 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 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" <[email protected]> wrote in message
news:[email protected]...
> In using this, the code stops after coping & pasting the 1st line of the
2nd
> last sheet.
> Any ideas
>
>
>
> "Ron Dean" <[email protected]> wrote in message
> news:[email protected]...
> > Fabulous, Bob.
> >
> > Can you briefly explain what was wrong with my attempt
> >
> > Rob
> > +++++++++++++++++++++
> >
> >
> > "Bob Phillips" <[email protected]> wrote in message
> > news:[email protected]...
> >>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" <[email protected]> wrote in message
> >> news:[email protected]...
> >>> 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
> >>>
> >>>
> >>
> >>
> >
> >
>
>