ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Paste blank cell row loop (https://www.excelbanter.com/excel-programming/350232-paste-blank-cell-row-loop.html)

Ron Dean[_2_]
Paste blank cell row loop
 
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[_6_]
Paste blank cell row loop
 
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

Ron Dean[_2_]
Paste blank cell row loop
 
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

Bob Phillips[_6_]
Paste blank cell row loop
 
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" 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

Ron Dean[_2_]
Paste blank cell row loop
 
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

Bob Phillips[_6_]
Paste blank cell row loop
 
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


All times are GMT +1. The time now is 05:46 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com