Sub SplitToFilesByAddress_Test10()
Dim wsSource As Worksheet
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim i As Long
Dim addressVal As String
Dim safeFileName As String
Dim savePath As String
' Check if file is saved
If ThisWorkbook.Path = "" Then
MsgBox "Please save this main file to a folder on your PC first.", vbExclamation
Exit Sub
End If
' Create test folder
savePath = ThisWorkbook.Path & "\Split_Addresses_Test\"
If Dir(savePath, vbDirectory) = "" Then
MkDir savePath
End If
Set wsSource = ThisWorkbook.ActiveSheet
' Optimize speed
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' TEST: Only process rows 2 through 11 (10 addresses)
For i = 2 To 11
addressVal = wsSource.Cells(i, 6).Text ' Column F is 6
If Trim(addressVal) <> "" Then
' Clean filename
safeFileName = addressVal
safeFileName = Replace(safeFileName, "/", "_")
safeFileName = Replace(safeFileName, "\", "_")
safeFileName = Replace(safeFileName, ":", "_")
safeFileName = Replace(safeFileName, "*", "_")
safeFileName = Replace(safeFileName, "?", "_")
safeFileName = Replace(safeFileName, """", "_")
safeFileName = Replace(safeFileName, "<", "_")
safeFileName = Replace(safeFileName, ">", "_")
safeFileName = Replace(safeFileName, "|", "_")
Set wbNew = Workbooks.Add
Set wsNew = wbNew.Sheets(1)
' Copy header (Row 1) and formats
wsSource.Rows(1).Copy
wsNew.Rows(1).PasteSpecial Paste:=xlPasteAll
wsNew.Rows(1).PasteSpecial Paste:=xlPasteColumnWidths
' Copy data row
wsSource.Rows(i).Copy
wsNew.Rows(2).PasteSpecial Paste:=xlPasteAll
' Save and close
wbNew.SaveAs Filename:=savePath & safeFileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wbNew.Close SaveChanges:=False
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Test Done! Created 10 files in: " & savePath, vbInformation
End Sub