macro to save 2 file ext. xlsx and csv when creating new workbook for unique values

[nash08]

Hi Guys,
Im creating a macro and found a code in internet for filtering unique data and copy to new workbook and creating folder for the new files. I tried to tweak it to :

*create folder by their worksheet Name
*saving and splitting the file to xlsx and csv
*naming the filename by their unique cell content . Also to bypass the name with / on it.( ex the data in cellB is January/23, i want the new filename to be january-23 or January.23

I created 2 module:

module1

[FONT=Verdana]Sub Copy_To_Workbooks()[/FONT]
[FONT=Verdana]'Note: This macro use the function LastRow[/FONT]
[FONT=Verdana]Dim My_Range As Range[/FONT]
[FONT=Verdana]Dim FieldNum As Long[/FONT]
[FONT=Verdana]Dim FileExtStr As String[/FONT]
[FONT=Verdana]Dim FileFormatNum As Long[/FONT]
[FONT=Verdana]Dim CalcMode As Long[/FONT]
[FONT=Verdana]Dim ViewMode As Long[/FONT]
[FONT=Verdana]Dim ws2 As Worksheet[/FONT]
[FONT=Verdana]Dim MyPath As String[/FONT]
[FONT=Verdana]Dim foldername As String[/FONT]
[FONT=Verdana]Dim Lrow As Long[/FONT]
[FONT=Verdana]Dim cell As Range[/FONT]
[FONT=Verdana]Dim CCount As Long[/FONT]
[FONT=Verdana]Dim WSNew As Worksheet[/FONT]
[FONT=Verdana]Dim ErrNum As Long[/FONT]
[FONT=Verdana]Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&[/FONT]
[FONT=Verdana]Dim theFilePath As String[/FONT]

[FONT=Verdana]'Set filter range on ActiveSheet: A11 is the top left cell of your filter range[/FONT]
[FONT=Verdana]'and the header of the first column, D is the last column in the filter range.[/FONT]
[FONT=Verdana]'You can also add the sheet name to the code like this :[/FONT]
[FONT=Verdana]'Worksheets("Sheet1").Range("A11:D" & LastRow(Worksheets("Sheet1")))[/FONT]
[FONT=Verdana]'No need that the sheet is active then when you run the macro when you use this.[/FONT]
[FONT=Verdana]Set My_Range = Range("A1:N" & LastRow(ActiveSheet))[/FONT]
[FONT=Verdana]My_Range.Parent.Select[/FONT]

[FONT=Verdana]If ActiveWorkbook.ProtectStructure = True Or _[/FONT]
[FONT=Verdana]My_Range.Parent.ProtectContents = True Then[/FONT]
[FONT=Verdana]MsgBox "Sorry, not working when the workbook or worksheet is protected", _[/FONT]
[FONT=Verdana]vbOKOnly, "Copy to new workbook"[/FONT]
[FONT=Verdana]Exit Sub[/FONT]
[FONT=Verdana]End If[/FONT]

[FONT=Verdana]'This example filters on the first column in the range(change the field if needed)[/FONT]
[FONT=Verdana]'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......[/FONT]
[FONT=Verdana]FieldNum = 2[/FONT]

[FONT=Verdana]'Turn off AutoFilter[/FONT]
[FONT=Verdana]My_Range.Parent.AutoFilterMode = False[/FONT]

[FONT=Verdana]'Set the file extension/format[/FONT]
[FONT=Verdana]If Val(Application.Version) < 12 Then[/FONT]

[FONT=Verdana]If ActiveWorkbook.FileFormat = 56 Then[/FONT]
[FONT=Verdana]FileExtStr = ".xls": FileFormatNum = 56[/FONT]
[FONT=Verdana]Else[/FONT]
[FONT=Verdana]FileExtStr = ".xlsx": FileFormatNum = 51[/FONT]
[FONT=Verdana]FileExtStr = ".csv": FileFormatNum = 6[/FONT]

[FONT=Verdana]End If[/FONT]
[FONT=Verdana]End If[/FONT]

[FONT=Verdana]'Change ScreenUpdating, Calculation, EnableEvents, ....[/FONT]
[FONT=Verdana]With Application[/FONT]
[FONT=Verdana]CalcMode = .Calculation[/FONT]
[FONT=Verdana].Calculation = xlCalculationManual[/FONT]
[FONT=Verdana].ScreenUpdating = False[/FONT]
[FONT=Verdana].EnableEvents = False[/FONT]
[FONT=Verdana]End With[/FONT]
[FONT=Verdana]ViewMode = ActiveWindow.View[/FONT]
[FONT=Verdana]ActiveWindow.View = xlNormalView[/FONT]
[FONT=Verdana]ActiveSheet.DisplayPageBreaks = False[/FONT]

[FONT=Verdana]'Delete the sheet RDBLogSheet if it exists[/FONT]
[FONT=Verdana]On Error Resume Next[/FONT]
[FONT=Verdana]Application.DisplayAlerts = False[/FONT]
[FONT=Verdana]Sheets("RDBLogSheet").Delete[/FONT]
[FONT=Verdana]Application.DisplayAlerts = True[/FONT]
[FONT=Verdana]On Error GoTo 0[/FONT]

[FONT=Verdana]' Add worksheet to copy/Paste the unique list[/FONT]
[FONT=Verdana]Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count))[/FONT]
[FONT=Verdana]ws2.Name = "RDBLogSheet"[/FONT]

[FONT=Verdana]'Fill in the path\folder where you want the new folder with the files[/FONT]
[FONT=Verdana]'you can use also this "C:\Users\Ron\test"[/FONT]
[FONT=Verdana]MyPath = Application.DefaultFilePath[/FONT]

[FONT=Verdana]'Add a slash at the end if the user forget it[/FONT]
[FONT=Verdana]If Right(MyPath, 1) <> "" Then[/FONT]
[FONT=Verdana]MyPath = MyPath & ""[/FONT]
[FONT=Verdana]End If[/FONT]

[FONT=Verdana]'Create folder for the new files[/FONT]

[FONT=Verdana]MyFilePath$ = ActiveWorkbook.Path & ""[/FONT]
[FONT=Verdana]For Each Sheet In ThisWorkbook.Worksheets[/FONT]
[FONT=Verdana]SheetName$ = Sheet.Name[/FONT]
[FONT=Verdana]With Application[/FONT]
[FONT=Verdana].ScreenUpdating = False[/FONT]
[FONT=Verdana].DisplayAlerts = False[/FONT]
[FONT=Verdana]' End With[/FONT]
[FONT=Verdana]On Error Resume Next '<< a folder exists[/FONT]
[FONT=Verdana]theFilePath = MyFilePath & SheetName[/FONT]
[FONT=Verdana]MkDir theFilePath[/FONT]
[FONT=Verdana]theFilePath = theFilePath & "" & Format(Date, "yyyy-mm-dd")[/FONT]
[FONT=Verdana]MkDir theFilePath[/FONT]
[FONT=Verdana]With Sheet[/FONT]
[FONT=Verdana].Select[/FONT]
[FONT=Verdana].Copy[/FONT]
[FONT=Verdana]ActiveWorkbook.SaveAs Filename:=theFilePath & "" & SheetName & ".xlsx", FileFormat _[/FONT]
[FONT=Verdana]:=xlOpenXMLWorkbook, CreateBackup:=False[/FONT]
[FONT=Verdana]ActiveWorkbook.Close[/FONT]
[FONT=Verdana]End With[/FONT]
[FONT=Verdana].CutCopyMode = False[/FONT]
[FONT=Verdana]End With[/FONT]
[FONT=Verdana]Next Sheet[/FONT]

[FONT=Verdana]With ws2[/FONT]
[FONT=Verdana]'first we copy the Unique data from the filter field to ws2[/FONT]
[FONT=Verdana]My_Range.Columns(FieldNum).AdvancedFilter _[/FONT]
[FONT=Verdana]Action:=xlFilterCopy, _[/FONT]
[FONT=Verdana]CopyToRange:=.Range("A3"), Unique:=True[/FONT]

[FONT=Verdana]'loop through the unique list in ws2 and filter/copy to a new sheet[/FONT]
[FONT=Verdana]Lrow = .Cells(Rows.Count, "A").End(xlUp).Row[/FONT]
[FONT=Verdana]For Each cell In .Range("A4:A" & Lrow)[/FONT]

[FONT=Verdana]'Filter the range[/FONT]
[FONT=Verdana]My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _[/FONT]
[FONT=Verdana]Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")[/FONT]

[FONT=Verdana]'Check if there are no more then 8192 areas(limit of areas)[/FONT]
[FONT=Verdana]CCount = 0[/FONT]
[FONT=Verdana]On Error Resume Next[/FONT]
[FONT=Verdana]CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _[/FONT]
[FONT=Verdana].Areas(1).Cells.Count[/FONT]
[FONT=Verdana]On Error GoTo 0[/FONT]
[FONT=Verdana]If CCount = 0 Then[/FONT]
[FONT=Verdana]MsgBox "There are more than 8192 areas for the value : " & cell.Value _[/FONT]
[FONT=Verdana]& vbNewLine & "It is not possible to copy the visible data." _[/FONT]
[FONT=Verdana]& vbNewLine & "Tip: Sort your data before you use this macro.", _[/FONT]
[FONT=Verdana]vbOKOnly, "Split in worksheets"[/FONT]
[FONT=Verdana]Else[/FONT]
[FONT=Verdana]'Add new workbook with one sheet[/FONT]
[FONT=Verdana]Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)[/FONT]

[FONT=Verdana]'Copy/paste the visible data to the new workbook[/FONT]
[FONT=Verdana]My_Range.SpecialCells(xlCellTypeVisible).Copy[/FONT]
[FONT=Verdana]With WSNew.Range("A1")[/FONT]
[FONT=Verdana]' Paste:=8 will copy the columnwidth in Excel 2000 and higher[/FONT]
[FONT=Verdana]' Remove this line if you use Excel 97[/FONT]
[FONT=Verdana].PasteSpecial Paste:=8[/FONT]
[FONT=Verdana].PasteSpecial xlPasteValues[/FONT]
[FONT=Verdana].PasteSpecial xlPasteFormats[/FONT]
[FONT=Verdana]Application.CutCopyMode = False[/FONT]
[FONT=Verdana].Select[/FONT]
[FONT=Verdana]End With[/FONT]

[FONT=Verdana]'Save the file in the new folder and close it[/FONT]
[FONT=Verdana]On Error Resume Next[/FONT]
[FONT=Verdana]WSNew.Parent.SaveAs theFilePath & _[/FONT]
[FONT=Verdana]cell.Value & FileExtStr, FileFormatNum[/FONT]
[FONT=Verdana]If Err.Number > 0 Then[/FONT]
[FONT=Verdana]Err.Clear[/FONT]
[FONT=Verdana]ErrNum = ErrNum + 1[/FONT]

[FONT=Verdana]WSNew.Parent.SaveAs theFilePath & _[/FONT]
[FONT=Verdana]"Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum[/FONT]

[FONT=Verdana].Cells(cell.Row, "B").Formula = "=Hyperlink(""" & theFilePath & _[/FONT]
[FONT=Verdana]"Error_" & Format(ErrNum, "0000") & FileExtStr & """)"[/FONT]

[FONT=Verdana].Cells(cell.Row, "A").Interior.Color = vbRed[/FONT]
[FONT=Verdana]Else[/FONT]
[FONT=Verdana].Cells(cell.Row, "B").Formula = _[/FONT]
[FONT=Verdana]"=Hyperlink(""" & theFilePath & cell.Value & FileExtStr & """)"[/FONT]
[FONT=Verdana]End If[/FONT]

[FONT=Verdana]WSNew.Parent.Close False[/FONT]
[FONT=Verdana]On Error GoTo 0[/FONT]
[FONT=Verdana]End If[/FONT]

[FONT=Verdana]'Show all the data in the range[/FONT]
[FONT=Verdana]My_Range.AutoFilter Field:=FieldNum[/FONT]

[FONT=Verdana]Next cell[/FONT]
[FONT=Verdana].Cells(1, "A").Value = "Red cell: can't use the Unique name as file name"[/FONT]
[FONT=Verdana].Cells(1, "B").Value = "Created Files (Click on the link to open a file)"[/FONT]
[FONT=Verdana].Cells(3, "A").Value = "Unique Values"[/FONT]
[FONT=Verdana].Cells(3, "B").Value = "Full Path and File name"[/FONT]
[FONT=Verdana].Cells(3, "A").Font.Bold = True[/FONT]
[FONT=Verdana].Cells(3, "B").Font.Bold = True[/FONT]
[FONT=Verdana].Columns("A:B").AutoFit[/FONT]

[FONT=Verdana]End With[/FONT]

[FONT=Verdana]'Turn off AutoFilter[/FONT]
[FONT=Verdana]My_Range.Parent.AutoFilterMode = False[/FONT]

[FONT=Verdana]If ErrNum > 0 Then[/FONT]
[FONT=Verdana]MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _[/FONT]
[FONT=Verdana]& vbNewLine & "There are characters in the name that are not allowed" _[/FONT]
[FONT=Verdana]& vbNewLine & "in a sheet name or the worksheet already exist."[/FONT]
[FONT=Verdana]End If[/FONT]

[FONT=Verdana]'Restore ScreenUpdating, Calculation, EnableEvents, ....[/FONT]
[FONT=Verdana]My_Range.Parent.Select[/FONT]
[FONT=Verdana]ActiveWindow.View = ViewMode[/FONT]
[FONT=Verdana]ws2.Select[/FONT]
[FONT=Verdana]With Application[/FONT]
[FONT=Verdana].ScreenUpdating = True[/FONT]
[FONT=Verdana].EnableEvents = True[/FONT]
[FONT=Verdana].Calculation = CalcMode[/FONT]
[FONT=Verdana]End With[/FONT]

[FONT=Verdana]End Sub[/FONT]

Module 2

[FONT=Verdana]Function LastRow(sh As Worksheet)[/FONT]
[FONT=Verdana]On Error Resume Next[/FONT]
[FONT=Verdana]LastRow = sh.Cells.Find(What:="*", _[/FONT]
[FONT=Verdana]After:=sh.Range("A1"), _[/FONT]
[FONT=Verdana]Lookat:=xlPart, _[/FONT]
[FONT=Verdana]LookIn:=xlValues, _[/FONT]
[FONT=Verdana]SearchOrder:=xlByRows, _[/FONT]
[FONT=Verdana]SearchDirection:=xlPrevious, _[/FONT]
[FONT=Verdana]MatchCase:=False).Row[/FONT]
[FONT=Verdana]On Error GoTo 0[/FONT]
[FONT=Verdana]End Function[/FONT]


[FONT=Verdana]Function SheetExists(SName As String, _[/FONT]
[FONT=Verdana]Optional ByVal WB As Workbook) As Boolean[/FONT]
[FONT=Verdana]'Chip Pearson[/FONT]
[FONT=Verdana]On Error Resume Next[/FONT]
[FONT=Verdana]If WB Is Nothing Then Set WB = ThisWorkbook[/FONT]
[FONT=Verdana]SheetExists = CBool(Len(WB.Sheets(SName).Name))[/FONT]
[FONT=Verdana]End Function[/FONT]

HOPE you can help

Thank you so much!