PDA

View Full Version : VbCode changes need review



Emoncada
01-02-2009, 08:49 AM
I found this code in this post. http://www.vbaexpress.com/forum/showthread.php?t=18992&highlight=move+row+to+another+sheet



Sub FilterAndCopy()
Dim lastRow As Long, lngRow As Long
Dim coll As Collection
Dim collItem As Variant
Dim copyR As Range
Application.ScreenUpdating = False
With Worksheets("Main")
If .AutoFilterMode = True Then .AutoFilterMode = False
lastRow = .Range("D" & .Rows.count).End(xlUp).Row


'Fill collection with unique Descriptions
Set coll = New Collection
On Error Resume Next
For lngRow = 6 To lastRow
coll.Add .Range("D" & lngRow).Value, .Range("D" & lngRow).Value
Next 'lngRow
If Err Then Err.Clear
On Error Goto 0


'For each Description copy the data
For Each collItem In coll
If WorksheetExists(collItem) Then
Worksheets(collItem).UsedRange.EntireRow.Delete
'Show only this Description's data
.Range("A5").AutoFilter Field:=4, Criteria1:=collItem
Set copyR = .UsedRange
copyR.Copy Worksheets(collItem).Range("A5")
With Worksheets(collItem)
.UsedRange.Value = .UsedRange.Value
lastRow = .UsedRange.Row + .UsedRange.Rows.count - 1
.Rows(lastRow).Copy .Range("A" & lastRow + 1)
.Rows(lastRow + 1).ClearContents
.Range("E" & lastRow + 1).Value = WorksheetFunction.Sum(.Range("E6:E" & lastRow))
.Range("F" & lastRow + 1).Value = WorksheetFunction.Sum(.Range("F6:F" & lastRow))
.Range("G" & lastRow + 1).Value = WorksheetFunction.Sum(.Range("G6:G" & lastRow))
End With
'Show all data
.Range("A5").AutoFilter
Else
MsgBox "Worksheet was not found for description '" & collItem & "'"
End If
Next 'collItem
End With
Application.ScreenUpdating = True
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function WorksheetExists(ByVal strSheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Not Worksheets(strSheetName) Is Nothing)
End Function


I keep getting an error and it highlights this

.Range("A5").AutoFilter Field:=4, Criteria1:=collItem

It wouldn't work for me so I made a minor change that seems to work, but would like to see if anyone see's why it didn't work the original way, otherwise if anyone see's how the change I made can impact something somewhere done the road.

With changes.

Sub FilterAndCopy2()
Dim lastRow As Long, lngRow As Long
Dim coll As Collection
Dim collItem As Variant
Dim copyR As Range
Application.ScreenUpdating = False
With Worksheets("Master")
If .AutoFilterMode = True Then .AutoFilterMode = False
lastRow = .Range("D" & .Rows.Count).End(xlUp).Row

'Fill collection with unique Descriptions
Set coll = New Collection
On Error Resume Next
For lngRow = 3 To lastRow
coll.Add .Range("D" & lngRow).Value, .Range("D" & lngRow).Value
Next 'lngRow
If Err Then Err.Clear
On Error GoTo 0

'For each Description copy the data
For Each collItem In coll
If WorksheetExists(collItem) Then
Worksheets(collItem).UsedRange.EntireRow.Delete
'Show only this Description's data
Rows("2").AutoFilter Field:=4, Criteria1:=collItem

Set copyR = .UsedRange
copyR.Copy Worksheets(collItem).Range("A2")
With Worksheets(collItem)
.UsedRange.Value = .UsedRange.Value
lastRow = .UsedRange.Row + .UsedRange.Rows.Count - 1
.Rows(lastRow).Copy .Range("A" & lastRow + 1)
.Rows(lastRow + 1).ClearContents
End With
'Show all data
.Range("A2").AutoFilter
Else
MsgBox "Worksheet was not found for description '" & collItem & "'"
End If
Next 'collItem
End With
Application.ScreenUpdating = True
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function WorksheetExists(ByVal strSheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Not Worksheets(strSheetName) Is Nothing)
End Function


Thanks

lucas
01-02-2009, 11:27 AM
Range A5 is the row where the data begins on the main sheet and the column being filtered by is column 4.......

Emoncada
01-02-2009, 11:33 AM
No the data begins in A2 and I want it filtered by Column 4. A5 is from the post I found I made the change to A2 in the script after.

lucas
01-02-2009, 12:07 PM
I'm just saying that you changed it to:
Rows("2").AutoFilter Field:=4, Criteria1:=collItem

I would try:


.Range("A2").AutoFilter Field:=4, Criteria1:=collItem

Emoncada
01-02-2009, 12:11 PM
That's what I originally tried but it would fail.
It gives me a

Run-time error '1004':
Autofilter method of Range class failed

That's when I tried the Row("2") and that worked.

Emoncada
01-02-2009, 01:51 PM
Now i am using Excel 2007. Could that cause a problem?

Aussiebear
01-02-2009, 04:19 PM
Can you post a sample workbook with the code?

Emoncada
01-05-2009, 06:30 AM
Here is the file. I apologize for the late reply.

Emoncada
01-06-2009, 11:39 AM
I also noticed that the macro removes the data in Sheet "Monitor". Any idea why that would do that?

Emoncada
01-07-2009, 08:55 AM
bump!

lucas
01-07-2009, 09:19 AM
Someone with 2007 will have to help you get any further with this....I don't have it.

Emoncada
01-08-2009, 11:25 AM
BUMP!