PDA

View Full Version : Copy and paste help required



Dowsey1977
12-15-2005, 03:45 AM
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
12-15-2005, 10:01 AM
Try this:


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

Dowsey1977
12-15-2005, 10:37 AM
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
12-16-2005, 07:44 AM
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
12-16-2005, 08:05 AM
OK, try this. It assumes that you want to cycle through every worksheet except FilterSheet, so don't go leaving blank worksheets laying about :devil:


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

Dowsey1977
12-16-2005, 08:16 AM
Ok....I slightly modified it to this, as there are blank sheets/sheets I don't want it to filter:

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


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

Dowsey1977
12-16-2005, 08:17 AM
And I changed all the ws's to ws1's and now it says "Object doesn't support this property or method"

matthewspatrick
12-16-2005, 08:19 AM
For Each ws In ws1

Dowsey1977
12-16-2005, 08:28 AM
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
12-16-2005, 09:44 AM
Is there a way to get this to continue the macro on the next sheet if no rows match the criteria??

Dowsey1977
12-16-2005, 10:26 AM
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
12-16-2005, 09:04 PM
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
12-19-2005, 04:07 AM
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
12-19-2005, 06:34 AM
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.




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




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
12-19-2005, 06:48 AM
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
12-19-2005, 07:00 AM
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:



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

Dowsey1977
12-19-2005, 07:30 AM
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
12-19-2005, 07:31 AM
Date worked just fine for me in Excel 2002.

Try Now instead.

Dowsey1977
12-19-2005, 08:02 AM
Tried Now and now it doesn't like the FORMAT part - it says can't find project or library??

matthewspatrick
12-19-2005, 08:14 AM
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

Dowsey1977
12-19-2005, 08:23 AM
I have references to all 4 of these checked - Excel and Office 11.0

matthewspatrick
12-19-2005, 08:28 AM
I have no idea what is wrong, then--those functions (Date and Now) are both valid VBA. The code I posted works in Excel 2002, and I cannot test Excel 2003.

Dowsey1977
12-19-2005, 08:33 AM
I have no idea either...works fine on Excel 97 too!! Must be something locked down on these work PC's.

Norie
12-19-2005, 09:17 AM
In the references are any marked as MISSING?

Dowsey1977
12-19-2005, 10:05 AM
I have a 'MISSING: Data Dynamics ActiveBar 2.0'??

mdmackillop
12-19-2005, 10:11 AM
Try removing the reference to the missing item.

Dowsey1977
12-19-2005, 10:19 AM
Right, I've removed the reference and that seems to have fixed the issue.

Now, the code relating to the initial query still isn't working properly. It is still saying 'No Cells Found' and when I click on Debug 'Dest.UsedRange.SpecialCells(xlCellTypeBlanks) = ws.Name' is highlighted.