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