Загрузка данных


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