Extract and copy Rows where value is Greater than 0 (zero)

[singh352]

Hello All,


I am using Office 2003/Windows XP and have a workbook with many sheets
(50+).
I wish to extract the rows from all the sheets in Column G, where the
value is equal to 1 or greater than 1.

Following is the sample sheet.. Data is not consistent.. I wish to copy
the complete row to a New Worksheet one below other from Sheet1 to the
end 50+ sheets.


A B C D E F G H

1 Data Data Data 0 Data
2 Data Data 1
3 blank row
4 blank row
5 Data Data 0
6 Data 2 Data
....
....
.....
Last Data is in Row No. 65

Is this possible thru VBA.

Any help would be greatly appreciated.

Thanks in advance

Ashish Kumar

 

[Tom Ogilvy]

Sub CopyData()
Dim sh as Worksheet
Dim sh1 as Worksheet
Dim i as long, rng as Range
Application.DisplayAlerts = False
On Error Resume Next
worksheets("Summary").Delete
On Error goto 0
Application.DisplayAlerts = True
set sh = worksheets.Add(after:=worksheets(worksheets.count))
sh.Name = "Summary"
for each sh1 in Worksheets
if sh1.Name <> sh.Name then
lastrow = sh1.cells(rows.count,7).End(xlup).row
for i = 2 to lastrow
if isnumeric(sh1.Cells(i,"G").Value) then
if sh1.cells(i,"G").Value >= 1 then
set rng = sh.cells(rows.count,7).End(xlup)(2,-5)
sh1.Cells(i,"G").EntireRow.copy Destination:=rng
end if
end if
Next
End if
Next
End Sub

 

[prkhan56]

WOW...Thanks Tom.
It works like a charm....but I am stumped with another problem...Is it
possible to have the respective sheet names in Column A and data from
the rows in Column B?.. Can you help please?

Thanks once again for your time and support.

Ashish Kumar

 

[Tom Ogilvy]

Sub CopyData()
Dim sh as Worksheet
Dim sh1 as Worksheet
Dim i as long, rng as Range
Dim col as Long
Application.DisplayAlerts = False
On Error Resume Next
worksheets("Summary").Delete
On Error goto 0
Application.DisplayAlerts = True
set sh = worksheets.Add(after:=worksheets(worksheets.count))
sh.Name = "Summary"
for each sh1 in Worksheets
if sh1.Name <> sh.Name then
lastrow = sh1.cells(rows.count,7).End(xlup).row
for i = 2 to lastrow
if isnumeric(sh1.Cells(i,"G").Value) then
if sh1.cells(i,"G").Value >= 1 then
set rng = sh.cells(rows.count,8).End(xlup)(2,-6)
rng.Value = sh1.Name
col = sh1.Cells(i,"IV4").End(xltoLeft)
sh1.Range(sh1.Cells(i,"G"), _
sh1.Cells(i,col)).copy Destination:=rng(1,2)
end if
end if
Next
End if
Next
End Sub

 

[singh352]

Tom
It gives the following error
Runtime error 1004
Application defined or object defined error
and highlights the following..
col = sh1.Cells(i,"IV4").End(xltoLef¬t)

Did I miss something?

Thanks once again for your time and help
Ashish Kumar

 

[Dave Peterson]

Copying and pasting from google seems to be adding extra characters. Tom's
original post didn't have that "not" symbol between the "f" and "t" in xltoleft.

col = sh1.Cells(i,"IV4").End(xltoLeft)

 

[singh352]

Thanks Dave.. but the code is not having any symbol between "f" and "t"
in xltoleft...

I checked it again on my system...the symbol appeared while I copied
the code from my system...

there is no symbol between "f" and "t"..

Can u guess what is wrong then?

Ashish Kumar

 

[Dave Peterson]

Try this:

col = sh1.Cells(i, "IV").End(xlToLeft).Column

And you may want to add one more declaration:

Dim LastRow as long
(Right at the top with the others.)

 

[singh352]

Hi Dave,
I tried your suggestion.. it does not give the desired result.. it
copies everything from all the sheets to Row No.2 in the Summary Sheet
and keeps on over writing on the same row until the last sheet in the
workbook... so what remains on Summary Sheet is the detail from the
last sheet.

Is this clear to you.
Thanks for your time
Ashish Kumar

 

[Dave Peterson]

You wanted the whole row copied from the original worksheets?

Option Explicit
Sub CopyData()
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim i As Long, rng As Range
Dim LastRow As Long
Dim col As Long
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
sh.Name = "Summary"
For Each sh1 In Worksheets
If sh1.Name <> sh.Name Then
LastRow = sh1.Cells(Rows.Count, 7).End(xlUp).Row
For i = 2 To LastRow
If IsNumeric(sh1.Cells(i, "G").Value) Then
If sh1.Cells(i, "G").Value >= 1 Then
Set rng = sh.Cells(Rows.Count, 1).End(xlUp)(2)
rng.Value = sh1.Name
col = sh1.Cells(i, "IV").End(xlToLeft).Column
sh1.Range(sh1.Cells(i, "A"), _
sh1.Cells(i, col)).Copy Destination:=rng(1, 2)
End If
End If
Next
End If
Next
End Sub

Tom's second code had this line:
sh1.Range(sh1.Cells(i, "G"), _
sh1.Cells(i, col)).Copy Destination:=rng(1, 2)

I changed it to column A:
sh1.Range(sh1.Cells(i, "A"), _
sh1.Cells(i, col)).Copy Destination:=rng(1, 2)

Tom's code copied from column G to the right. If you wanted that, change the
code back.