Copy and paste help required

[Dowsey1977]

Hi,

I have a workbook with about 10 sheets in it. What I want to do is copy the first 5 columns of data onto a consolidation sheet, where the contents of column 10 for each row match a criteria, in this case, today's date.
I also want to put the name of the sheet in a 6th column.

I can work out a really long way of filtering and copying sheet, but what I wanted was help with perhaps a quicker way of doing the copying and pasting and then also how to get the sheet name on the end. Obviously, the amount of rows will vary, so it just needs to go with how ever many rows meet the criteria.

Any ideas appreciated!

[matthewspatrick]

Try this:

[VBA]
Sub Consol()

Dim ws As Worksheet
Dim Dest As Worksheet
Dim FirstOne As Boolean
Dim LastRow As Long

Set Dest = Workbooks.Add.Worksheets(1)

FirstOne = True

For Each ws In ThisWorkbook.Worksheets
LastRow = ws.[a65536].End(xlUp).Row
[f1] = "Sheet Name"
ws.[a1].AutoFilter Field:=10, Criteria1:=Date, Operator:=xlAnd
If FirstOne Then
ws.[A:E].SpecialCells(xlCellTypeVisible).Copy Dest.[a1]
FirstOne = False
Else
Range(ws.Cells(2, 1), ws.Cells(LastRow, 5)).Copy Dest.[a65536].End(xlUp).Offset(1, 0)
End If
Dest.UsedRange.SpecialCells(xlCellTypeBlanks) = ws.Name
Next

End Sub
[/VBA]

[Dowsey1977]

Many thanks for this.
When I ran the code, it opened a whole new workbook. The 10 sheets I have already exist and they will be altered by users on an ongoing basis.
What I want is to have a macro so that each rows in A:F on each sheet is copied to FilterSheet if they meet the date criteria.

[Dowsey1977]

Ok, here is an example of my spreadsheet, I actually have a load of other sheets that are similar to AccOpening. What I want to do is filter each sheets range A:F and then copy the rows that meet the criteria (which I want to be the date) to FilterSheet. I would also like to add the sheet name to the last column on FilterSheet, e.g. AccOpening

Any ideas

[matthewspatrick]

OK, try this. It assumes that you want to cycle through every worksheet except FilterSheet, so don't go leaving blank worksheets laying about

[VBA]
Sub Consol()

Dim ws As Worksheet
Dim Dest As Worksheet
Dim LastRow As Long

Set Dest = ThisWorkbook.Worksheets("FilterSheet")
Dest.[a2:a65536].EntireRow.Delete

For Each ws In ThisWorkbook.Worksheets
If Not ws Is Dest Then
If ws.FilterMode Then ws.[a1].AutoFilter
LastRow = ws.[a65536].End(xlUp).Row
ws.[a1].AutoFilter Field:=10, Criteria1:=Format(Date, ws.[j2].NumberFormat), Operator:=xlAnd
Range(ws.Cells(2, 1), ws.Cells(LastRow, 5)).SpecialCells(xlCellTypeVisible).Copy _
Dest.[a65536].End(xlUp).Offset(1, 0)
Dest.UsedRange.SpecialCells(xlCellTypeBlanks) = ws.Name
ws.[a1].AutoFilter
End If
Next

End Sub

[/VBA]

[Dowsey1977]

Ok....I slightly modified it to this, as there are blank sheets/sheets I don't want it to filter:
[VBA]
Sub Consol()

Dim ws As Worksheet
Dim Dest As Worksheet
Dim LastRow As Long

Dim ws1 As New Collection
With ws1
.Add Sheets("AccOpening")
.Add Sheets("AccClose")
.Add Sheets("CardQueries")
.Add Sheets("Credit")
.Add Sheets("Deceased")
.Add Sheets("ExcessReports")
.Add Sheets("NonReceipt")
.Add Sheets("Payments")
.Add Sheets("Queries")
.Add Sheets("Renewals")
.Add Sheets("Reviews")
.Add Sheets("SalePurchase")
.Add Sheets("Switches")
.Add Sheets("Tax")
.Add Sheets("TransIn")
.Add Sheets("TransOut")
End With

Set Dest = ThisWorkbook.Worksheets("FilterSheet")
Dest.[a2:a65536].EntireRow.Delete

For Each Worksheet In ws1
If Not ws Is Dest Then
If ws.FilterMode Then ws.[a1].AutoFilter
LastRow = ws.[a65536].End(xlUp).Row
ws.[a1].AutoFilter Field:=10, Criteria1:=Format(Date, ws.[j2].NumberFormat), Operator:=xlAnd
Range(ws.Cells(2, 1), ws.Cells(LastRow, 5)).SpecialCells(xlCellTypeVisible).Copy _
Dest.[a65536].End(xlUp).Offset(1, 0)
Dest.UsedRange.SpecialCells(xlCellTypeBlanks) = ws.name
ws.[a1].AutoFilter
End If
Next

End Sub
[/VBA]

But I get an error mesage saying "Object Variable or With Block variable not set"?????

[Dowsey1977]

And I changed all the ws's to ws1's and now it says "Object doesn't support this property or method"

[matthewspatrick]

For Each ws In ws1

[Dowsey1977]

Excellent! That is pretty much working! But, it is now saying "No Cells were found", but it has copied from the first sheet. Is this saying that now rows meet the criteria?? If so, can I add something in to just carry onto the next sheet if nothing is found??

[Dowsey1977]

Is there a way to get this to continue the macro on the next sheet if no rows match the criteria??

[Dowsey1977]

And something else I've just realised, the date column is not always column 10, depending on how many columns are on each sheet this may vary.

I was initially trying an advanced filtercopy, but can't work out how to get this to work!

[matthewspatrick]

Getting it to work if the filter leaves no valid rows is easy. However, shifting the column with the filtered date is very problematic.

[Dowsey1977]

Ok, I've tried a few ways to get it to skips sheets where there is no rows that meet the criteria, but can't get it to work.

Also, to combat the column with the filter date, would an advanced filter do this??

[matthewspatrick]

This should address the 'no data for the criterion' problem. As for the problem of the date column not always being the same, the advanced filter will not help that.



[VBA]
Sub Consol()

Dim ws As Worksheet
Dim Dest As Worksheet
Dim LastRow As Long
Dim ws1 As New Collection

With ws1
.Add Sheets("AccOpening")
.Add Sheets("AccClose")
.Add Sheets("CardQueries")
.Add Sheets("Credit")
.Add Sheets("Deceased")
.Add Sheets("ExcessReports")
.Add Sheets("NonReceipt")
.Add Sheets("Payments")
.Add Sheets("Queries")
.Add Sheets("Renewals")
.Add Sheets("Reviews")
.Add Sheets("SalePurchase")
.Add Sheets("Switches")
.Add Sheets("Tax")
.Add Sheets("TransIn")
.Add Sheets("TransOut")
End With

Set Dest = ThisWorkbook.Worksheets("FilterSheet")
Dest.[a2:a65536].EntireRow.Delete

For Each Worksheet In ws1
If ws.FilterMode Then ws.[a1].AutoFilter
LastRow = ws.[a65536].End(xlUp).Row
ws.[a1].AutoFilter Field:=10, Criteria1:=Format(Date, ws.[j2].NumberFormat), Operator:=xlAnd
On Error Resume Next
Range(ws.Cells(2, 1), ws.Cells(LastRow, 5)).SpecialCells(xlCellTypeVisible).Copy _
Dest.[a65536].End(xlUp).Offset(1, 0)
On Error GoTo 0
Dest.UsedRange.SpecialCells(xlCellTypeBlanks) = ws.Name
ws.[a1].AutoFilter
Next

End Sub

[/VBA]


Addressing the 'roving column' problem can be done only if the following assumptions are both true:

1. Every 'detail' worksheet uses the same heading for the date column, wherever it might be, and that heading is used just once per sheet. (If this is true, then we can do a Find to determine which column has the date criterion.)

2. No matter what column has that date, we only ever copy the first five columns to the destination worksheet.

[Dowsey1977]

Thanks for the above code!

Thankfully, both conditions above are true re. the date. The first 5 columns are standard, so these are always going to need to be copied, and they are in the same order. And the date column to filter on is always called 'Follow-Up Date'.

Something else, I have been writing all this using Excel 97, now I am trying to run it on a 2003 version and there is a load of the code Excel doesn't like - could I be missing some add-in or something?? For example, Excel 2003 doesn't seem to be liking Format(Date, "d-mmmm-yy")??

[matthewspatrick]

Thanks for the above code!

Thankfully, both conditions above are true re. the date. The first 5 columns are standard, so these are always going to need to be copied, and they are in the same order. And the date column to filter on is always called 'Follow-Up Date'.

Based on that, it should be doable. See the revised code below.

Something else, I have been writing all this using Excel 97, now I am trying to run it on a 2003 version and there is a load of the code Excel doesn't like - could I be missing some add-in or something?? For example, Excel 2003 doesn't seem to be liking Format(Date, "d-mmmm-yy")??

Why are you doing that? Your sample file does not follow that number format! (Your sample file was d-mmm-yy.)

This is the reason why I specifically interrogated the date cell in Row 2 to see what its numberformat was.

Here's the final revision:


[VBA]
Sub Consol()

Dim ws As Worksheet
Dim Dest As Worksheet
Dim LastRow As Long
Dim ws1 As New Collection
Dim DateCol As Long

With ws1
.Add Sheets("AccOpening")
.Add Sheets("AccClose")
.Add Sheets("CardQueries")
.Add Sheets("Credit")
.Add Sheets("Deceased")
.Add Sheets("ExcessReports")
.Add Sheets("NonReceipt")
.Add Sheets("Payments")
.Add Sheets("Queries")
.Add Sheets("Renewals")
.Add Sheets("Reviews")
.Add Sheets("SalePurchase")
.Add Sheets("Switches")
.Add Sheets("Tax")
.Add Sheets("TransIn")
.Add Sheets("TransOut")
End With

Set Dest = ThisWorkbook.Worksheets("FilterSheet")
Dest.[a2:a65536].EntireRow.Delete

For Each Worksheet In ws1
If ws.FilterMode Then ws.[a1].AutoFilter
LastRow = ws.[a65536].End(xlUp).Row
DateCol = Application.Match("Follow-Up Date", ws.[1:1], 0)
ws.[a1].AutoFilter Field:=DateCol, Criteria1:=Format(Date, ws.Cells(2, DateCol).NumberFormat), _
Operator:=xlAnd
On Error Resume Next
Range(ws.Cells(2, 1), ws.Cells(LastRow, 5)).SpecialCells(xlCellTypeVisible).Copy _
Dest.[a65536].End(xlUp).Offset(1, 0)
On Error GoTo 0
Dest.UsedRange.SpecialCells(xlCellTypeBlanks) = ws.Name
ws.[a1].AutoFilter
Next

End Sub
[/VBA]

[Dowsey1977]

Thanks for the code.

The format of the date doesn't seem to matter, it is the 'Date' part it the VBA is not recognising??

[matthewspatrick]

Date worked just fine for me in Excel 2002.

Try Now instead.

[Dowsey1977]

Tried Now and now it doesn't like the FORMAT part - it says can't find project or library??

[matthewspatrick]

I am guessing that you have a broken reference. Please check to make sure that you have references to the following in your VB Project:

Visual Basic for Applications
Microsoft Excel x.y Object Library
Microsoft Office x.y Object Library
OLE Automation