Can you please help modify this VBA?
I have a spreadsheet called certify where I need to filter 2 columns( company and payroll batch) then copy and paste columns A to Z onto its own spreadsheet based on company and payroll batch
Company number is in column "F" and Payroll batch "AB"
I believe this macro should filter by the company number and copy and paste onto a new spreadsheet it created based on the company number filtered.
First I have no idea how to add the second filter on column AB the item to be filtered is "X"
second the macro is failing at the next r
Please help
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
currentWS.UsedRange.AutoFilter
I have a spreadsheet called certify where I need to filter 2 columns( company and payroll batch) then copy and paste columns A to Z onto its own spreadsheet based on company and payroll batch
Company number is in column "F" and Payroll batch "AB"
I believe this macro should filter by the company number and copy and paste onto a new spreadsheet it created based on the company number filtered.
First I have no idea how to add the second filter on column AB the item to be filtered is "X"
second the macro is failing at the next r
Please help
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
currentWS.UsedRange.AutoFilter