PDA

View Full Version : Solved: Extract Data from multi worksheets



James Niven
07-29-2009, 07:18 PM
I have various tabs of a worksheet with data all are the same number of columns but different number of rows. I wish to extract from each worksheet the entire row to a summary sheet based on the cell value in column B if it equals the number zero.

I then want to delete that row in each of the tabs where the zero in column B resides.

I have an attachment with sample data.
I found sample code from one of the posts, it works fine for on sheet and but does not move to the next sheet.

Thanks

James

Benzadeus
07-30-2009, 08:08 AM
Sub ExtractRows()
Dim i As Long 'increment for rows in the report sheet.
Dim n As Long 'for loop through each sheet's row values.
Dim rLast As Long
Dim sht As Worksheet
Dim shtReport As Worksheet

Const rHeaderOffset As Long = 2 'this is the row where your data begins.
Const cValues As String = "B" 'this is the column where we have the values.

Set shtReport = Sheets.Add
shtReport.Name = "Report" 'just to make things make sense.

i = 2 'this is the row where the first found 0 row value will be inserted
'in the report sheet.

For Each sht In Sheets
With sht
If sht.Name <> shtReport.Name Then
rLast = .Cells(.Rows.Count, cValues).End(xlUp).Row
For n = rHeaderOffset To rLast
If .Cells(n, cValues) = 0 And WorksheetFunction.CountA(.Rows(n)) > 0 Then
.Rows(n).EntireRow.Copy Destination:=shtReport.Rows(i)
i = i + 1
End If
Next n
End If
End With
Next sht
Set shtReport = Nothing
End Sub

James Niven
07-30-2009, 10:29 AM
Hi Benzadeus,

Thanks for the quick reply and your code works very well.

I still require the second part of my question as outlined below:

Once to Zero rows have been copied over, I wish to delete each zero row from each of the tabs where the zero in column B resides.

Thanks

James

mdmackillop
07-30-2009, 10:52 AM
Try this variation. The copied order will be reversed though.

For Each sht In Sheets
With sht
If sht.Name <> shtReport.Name Then
rLast = .Cells(.Rows.Count, cValues).End(xlUp).Row
For n = rLast To rHeaderOffset Step -1
If .Cells(n, cValues) = 0 And WorksheetFunction.CountA(.Rows(n)) > 0 Then
.Rows(n).EntireRow.Copy Destination:=shtReport.Rows(i)
.Rows(n).Delete
i = i + 1
End If
Next n
End If
End With
Next sht

Benzadeus
07-30-2009, 11:39 AM
Hi Benzadeus,

Thanks for the quick reply and your code works very well.

I still require the second part of my question as outlined below:

Once to Zero rows have been copied over, I wish to delete each zero row from each of the tabs where the zero in column B resides.

Thanks

James

I misunderstood, sorry. Use MD's code.

James Niven
07-30-2009, 12:05 PM
Benzadeus/mdmackillop,

I appreciate both of your code lines.

Benzadeus, no problem at all, you steered me in the right direction.

mdmackillop, thanks this worked fantastic!!!

Thanks to both of you!!

This is avery good site to gain knowledge and get help!