Hi, I am trying to modify a macro to filter copy and paste data from one spreadsheet to another based on 2 criteria. I found some code but I am having a little bit of trouble modifying. I know right now this is only filtering on the company and I need help adding the filter on column AB.
I believe the macro below creates a new spreadsheet based on the company number.
Basic information
the spreadsheet name is Certify and the range to copy is columns A to Z
We need to filter on the company code in column F ( for example : 20)
and " X "on column AB
when I try to run the macro it is stopping after the next r "currentWS.UsedRange.AutoFilter"
I believe the macro below creates a new spreadsheet based on the company number.
Basic information
the spreadsheet name is Certify and the range to copy is columns A to Z
We need to filter on the company code in column F ( for example : 20)
and " X "on column AB
when I try to run the macro it is stopping after the next r "currentWS.UsedRange.AutoFilter"
VBA Code:
Sub FilterThenCopy()
Dim ws, newWS, currentWS As Worksheet
targetCol = 6 'define which column you want to break
Dim objDict As Variant
Set objDict = CreateObject("Scripting.Dictionary")
Set currentWS = ActiveSheet
'Add unique value in targetCol to the dictionary
Application.DisplayAlerts = False
For r = 2 To Cells(Rows.Count, targetCol).End(xlUp).Row
If Not objDict.exists(Cells(r, targetCol).Value) Then
objDict.Add Cells(r, targetCol).Value, Cells(r, targetCol).Value
End If
Next r
If currentWS.AutoFilterMode = True Then
currentWS.UsedRange.AutoFilter
End If
currentWS.UsedRange.AutoFilter
For Each k In objDict.Keys
currentWS.UsedRange.AutoFilter field:=targetCol, Criteria1:=objDict.Item(k)
'delete worksheet if worksheet of item(k) exist
For Each ws In ActiveWorkbook.Worksheets
If wsExists(objDict.Item(k)) Then
Sheets(objDict.Item(k)).Delete
End If
Next ws
'crate worksheet using item(k) name
Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
newWS.Name = objDict.Item(k)
'copy filtered contents to new worksheet
currentWS.UsedRange.SpecialCells(xlCellTypeVisible).Copy
newWS.Range("A1:Z50000").Select
newWS.Paste
Next k
currentWS.Activate
currentWS.AutoFilterMode = False
Application.DisplayAlerts = True
End Sub
Function wsExists(wksName As String) As Boolean
On Error Resume Next
wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
On Error GoTo 0
End Function
Last edited by a moderator: