Wikipedia

Search results

Friday 20 December 2013

Advance Filter With VBA.......



Sub Testing()
Application.ScreenUpdating = False
Dim wkb As ThisWorkbook
Dim MyRang As Range
Dim h As Variant
Dim RowCount As Integer
Dim Rng As Range
Dim Fso As FileSystemObject
Dim Fpath As String
Dim Fldr As String
Dim Workbk_name As String
Dim LoopCount As Integer
Fpath = "D:\"
Set MyRang = Range("A1").CurrentRegion
Fldr = Fpath & Format(Now(), "DD-MMM-YYYY")
RowCount = Cells(Rows.Count, 6).End(xlUp).Row
h = Cells(1, 6).Resize(RowCount, 1)
Cells(1, 9).Resize(RowCount, 1).Value = h

LoopCount = Cells(Rows.Count, 9).End(xlUp).Row
Set Fso = New FileSystemObject
If Not Fso.FolderExists(Fldr) Then
Fso.CreateFolder Fpath & Format(Now(), "DD-MMM-YYYY")
Else
    MsgBox "Folder already exists!!!!!", vbExclamation, "Folder Exists"
    Sheet1.Range("i:i").Clear
Exit Sub
End If


        For i = 2 To LoopCount
        Range("i1:i" & RowCount).RemoveDuplicates Columns:=1, Header:=xlYes
        Set Rng = Range("a1").CurrentRegion
        Rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("i1:i2"), Copytorange:=Range("L1"), unique:=True
        Range("L1").CurrentRegion.Select
        Selection.Copy
        Application.Workbooks.Add
        ActiveWorkbook.Sheets(1).Select
        Range("A1").Select
        ActiveCell.PasteSpecial (xlPasteAll)
        Selection.Columns.AutoFit
        Workbk_name = Application.Workbooks("FORMAT").Sheets(1).Range("i2")
        ActiveWorkbook.SaveAs Filename:=Fldr & "\" & Workbk_name & ".xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        ActiveWorkbook.Close
        Workbooks("Format").Activate
        Range("i3:i" & LoopCount).Select
        Selection.Copy
        Range("i2").Select
        Selection.PasteSpecial (xlPasteAll)
        Range("i1:i" & RowCount).RemoveDuplicates Columns:=1, Header:=xlYes
        If Range("i2").Value = "" Then
        Exit For
End If
Range("L1").CurrentRegion.ClearContents
Next i
ActiveWorkbook.Sheets(1).Range("i1:q" & LoopCount).Select
Selection.Clear
Range("A1").Select
MsgBox "Done....", vbInformation, "Vikas Verma"


End Sub

Workbook



No comments:

Post a Comment