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
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