JOEYSCLEE
04-06-2018, 07:35 PM
Hi, there
Recently, the code cannot be run successfully. (The original file name - Filter Testing Example 3)
Errors are Duplicated record (1 of Unique values is duplicated) after running the code and the Header can't be copied to each new workbook.
Meanwhile, the Header is copied to the individual file. Please help to review and advise how to correct the code.:help
21989
Sub Filter()
Dim dic As Object
Dim ws As Worksheet
Dim fName As String
Dim i As Long, Vendor As String
Dim CalcMode As Long
Set dic = CreateObject("scripting.dictionary")
Set ws = ActiveSheet
'Use the INSTR function to find the ".", then use the LEFT to extract everthing before it
fName = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
With ws.Cells(3, 1).CurrentRegion
For i = 2 To .Rows.Count
Vendor = .Cells(i, 8).Value
If Not dic.exists(Vendor) Then
dic(Vendor) = True
ws.Copy
With ActiveSheet
With .Cells(3, 1).CurrentRegion
.AutoFilter
.AutoFilter 8, "<>" & Vendor
Application.DisplayAlerts = False
.Offset(1).Delete
Application.DisplayAlerts = True
.AutoFilter
End With
Application.Goto .Cells(1)
Application.DisplayAlerts = False
.Parent.SaveAs ws.Parent.Path & "\" & fName & "_" & Vendor & ".xlsx"
Application.DisplayAlerts = True
.Parent.Close
End With
End If
Next
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
21988
Recently, the code cannot be run successfully. (The original file name - Filter Testing Example 3)
Errors are Duplicated record (1 of Unique values is duplicated) after running the code and the Header can't be copied to each new workbook.
Meanwhile, the Header is copied to the individual file. Please help to review and advise how to correct the code.:help
21989
Sub Filter()
Dim dic As Object
Dim ws As Worksheet
Dim fName As String
Dim i As Long, Vendor As String
Dim CalcMode As Long
Set dic = CreateObject("scripting.dictionary")
Set ws = ActiveSheet
'Use the INSTR function to find the ".", then use the LEFT to extract everthing before it
fName = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
With ws.Cells(3, 1).CurrentRegion
For i = 2 To .Rows.Count
Vendor = .Cells(i, 8).Value
If Not dic.exists(Vendor) Then
dic(Vendor) = True
ws.Copy
With ActiveSheet
With .Cells(3, 1).CurrentRegion
.AutoFilter
.AutoFilter 8, "<>" & Vendor
Application.DisplayAlerts = False
.Offset(1).Delete
Application.DisplayAlerts = True
.AutoFilter
End With
Application.Goto .Cells(1)
Application.DisplayAlerts = False
.Parent.SaveAs ws.Parent.Path & "\" & fName & "_" & Vendor & ".xlsx"
Application.DisplayAlerts = True
.Parent.Close
End With
End If
Next
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
21988