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


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
    
    ' FIX: Start from row 3 (data), process 10 rows (up to 12)
    For i = 3 To 12
        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)
            
            ' FIX: Copy REAL header (Row 2) to the first row of new file
            wsSource.Rows(2).Copy
            wsNew.Rows(1).PasteSpecial Paste:=xlPasteAll
            wsNew.Rows(1).PasteSpecial Paste:=xlPasteColumnWidths
            
            ' Copy data to the second row of new file
            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