oam
06-25-2015, 04:36 PM
I am using Ron De Bruin’s code shown below to sort a source worksheet by the Active Cell, create a new workbook, and paste the results in the new workbook (Sort Workbook). The users have asked if the code could also return the row number of the source document so they can find the part number quickly in a worksheet of 1000+ rows. The output that I am hoping for is shown below, the sort is run on the Source Worksheet and the Sort Results would show the sort information to include the row number the data is located on.
Hope this is clear and thank you any and all help
Source Worksheet:
Row Number
Part Number
Part Only
Tracking Number
1
268300484
Part Only
1ZX29W123456789123
2
268214017
Part Only
1ZX29W123456789123
3
268585635
Part Only
1ZX29W123456789123
4
268585635
Part Only
1ZX29W123456789123
5
268269077
Part Only
1ZX29W123456789123
6
268207016
Part Only
1ZX29W123456789123
7
268206280
Part Only
1ZX29W123456789123
Sort Results:
Row Number
Part Number
Part Only
Tracking Number
3
268585635
Part Only
1ZX29W12345678912
4
268585635
Part Only
1ZX29W12345678912
Sub Filter_By_Color()
Dim ACell As Range
Dim WSNew As Worksheet
Dim Rng As Range
Dim ActiveCellInTable As Boolean
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet MyFilterResult if it exists
''On Error Resume Next
''Application.DisplayAlerts = False
''Sheets("MyFilterResult").Delete
''Application.DisplayAlerts = True
''On Error GoTo 0
'Remember the activecell
Set ACell = ActiveCell
'Test if ACell is in a Table or in a Normal range
On Error Resume Next
ActiveCellInTable = (ACell.ListObject.Name <> "")
On Error GoTo 0
'Optional set the Filter range
If ActiveCellInTable = False Then
'Your data is in a Normal range.
'If there are empty rows or columns in your data range you
'can make sure that Excel uses the correct data range here.
'If you do not use these three lines Excel will guess what
'your range is. Here we assume that A1 is the top left cell
'of your filter range and the header of the first column and
'that C is the last column in the filter range
' Set Rng = Range("A1:C" & ActiveSheet.Rows.Count)
' Rng.Select
' ACell.Activate
Else
'Your data is in a Table
'No problem if there are empty rows or columns if your data.
'is in a Table so there is no need to set a range because
'it automatically uses the whole table.
End If
'Call the built-in filter option to filter on ACell
Application.CommandBars("Cell").FindControl _
(ID:=12233, Recursive:=True).Execute
'Control Id Description
'12232 Filter by Selected Cell's Value
'12233 Filter by Selected Cell's Color
'12234 Filter by Selected Cell's Font Color
'12235 Filter by Selected Cell's Icon
ACell.Select
'Copy the Visible data into a new worksheet
If ActiveCellInTable = False Then
On Error Resume Next
ACell.Parent.AutoFilter.Range.Copy
If err.Number > 0 Then
MsgBox "Select a cell in your data range"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End If
Else
ACell.ListObject.Range.SpecialCells(xlCellTypeVisible).Copy
End If
'Add a new worksheet to copy the filter results in
''Set WSNew = Worksheets.Add
Set WSNew = Workbooks.Add.Worksheets(1)
WSNew.Name = "MyFilterResult"
With WSNew.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Close AutoFilter
ACell.AutoFilter
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Hope this is clear and thank you any and all help
Source Worksheet:
Row Number
Part Number
Part Only
Tracking Number
1
268300484
Part Only
1ZX29W123456789123
2
268214017
Part Only
1ZX29W123456789123
3
268585635
Part Only
1ZX29W123456789123
4
268585635
Part Only
1ZX29W123456789123
5
268269077
Part Only
1ZX29W123456789123
6
268207016
Part Only
1ZX29W123456789123
7
268206280
Part Only
1ZX29W123456789123
Sort Results:
Row Number
Part Number
Part Only
Tracking Number
3
268585635
Part Only
1ZX29W12345678912
4
268585635
Part Only
1ZX29W12345678912
Sub Filter_By_Color()
Dim ACell As Range
Dim WSNew As Worksheet
Dim Rng As Range
Dim ActiveCellInTable As Boolean
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet MyFilterResult if it exists
''On Error Resume Next
''Application.DisplayAlerts = False
''Sheets("MyFilterResult").Delete
''Application.DisplayAlerts = True
''On Error GoTo 0
'Remember the activecell
Set ACell = ActiveCell
'Test if ACell is in a Table or in a Normal range
On Error Resume Next
ActiveCellInTable = (ACell.ListObject.Name <> "")
On Error GoTo 0
'Optional set the Filter range
If ActiveCellInTable = False Then
'Your data is in a Normal range.
'If there are empty rows or columns in your data range you
'can make sure that Excel uses the correct data range here.
'If you do not use these three lines Excel will guess what
'your range is. Here we assume that A1 is the top left cell
'of your filter range and the header of the first column and
'that C is the last column in the filter range
' Set Rng = Range("A1:C" & ActiveSheet.Rows.Count)
' Rng.Select
' ACell.Activate
Else
'Your data is in a Table
'No problem if there are empty rows or columns if your data.
'is in a Table so there is no need to set a range because
'it automatically uses the whole table.
End If
'Call the built-in filter option to filter on ACell
Application.CommandBars("Cell").FindControl _
(ID:=12233, Recursive:=True).Execute
'Control Id Description
'12232 Filter by Selected Cell's Value
'12233 Filter by Selected Cell's Color
'12234 Filter by Selected Cell's Font Color
'12235 Filter by Selected Cell's Icon
ACell.Select
'Copy the Visible data into a new worksheet
If ActiveCellInTable = False Then
On Error Resume Next
ACell.Parent.AutoFilter.Range.Copy
If err.Number > 0 Then
MsgBox "Select a cell in your data range"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End If
Else
ACell.ListObject.Range.SpecialCells(xlCellTypeVisible).Copy
End If
'Add a new worksheet to copy the filter results in
''Set WSNew = Worksheets.Add
Set WSNew = Workbooks.Add.Worksheets(1)
WSNew.Name = "MyFilterResult"
With WSNew.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
'Close AutoFilter
ACell.AutoFilter
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub