Split data into separate file and save according to filename

[pesteness]

Hi Admin,

about the "split data program" i noticed that the "column A" (file name) is also in the output of the program, i just want to removed the column A (file name) on the output and the part number should start in that column, that file name is just for the files name. thanks god bless

.

[Admin]

Hi,

Try this code. Also type 1 in C6 on ControlSheet

'ExcelFox.com
Const Ttle        As String = "ExcelFox.com"
Sub SplitDataIntoMultipleFiles_V1()
    
    Dim wbkActive           As Workbook
    Dim strFolderPath       As String
    Dim varCols             As Variant
    Dim lngSplitCol         As Long
    Dim strOutPutFolder     As String
    Dim strFileFormat       As String
    Dim wksData             As Worksheet
    Dim blnSplitAllCol      As Boolean
    Dim varUniques          As Variant
    Dim strDataRange        As String
    Dim rngData             As Range
    Dim lngLoop             As Long
    Dim lngLoopCol          As Long
    Dim rngToCopy           As Range
    Dim wbkNewFile          As Workbook
    Dim i                   As Long
    Dim lngFileFormatNum    As Long
    Dim NewFileName         As String
    
    
    On Error Resume Next
    Set wbkActive = ThisWorkbook
    Set wksData = wbkActive.Worksheets(CStr(Range("wksName")))
    If Err.Number <> 0 Then
        MsgBox "Sheet name '" & Range("wksName").Text & "' not found", vbCritical, Ttle
        Err.Clear
        Exit Sub
    End If
    strFolderPath = wbkActive.Path & Application.PathSeparator
    If Len(Range("DataCols")) Then
        varCols = Split(Range("DataCols").Value, ",")
    Else
        blnSplitAllCol = True
    End If
    If Len(Range("SplitCol").Value) = 0 Then
        MsgBox "Column to Split must not be empty", vbCritical, Ttle
        Err.Clear
        Exit Sub
    End If
    lngSplitCol = CLng(Range("SplitCol").Value)
    
    If Right$(Range("OutputFolderPath"), 1) <> "\" Then
        strOutPutFolder = Range("OutputFolderPath") & "\"
    End If
    
    If Not CBool(Len(Dir(strOutPutFolder, 16))) Then
        strOutPutFolder = strFolderPath
    End If
    
    strFileFormat = IIf(Len(Range("OutputFileFormat").Text), Range("OutputFileFormat").Text, ".CSV")
    
    If Len(Range("DataRange")) = 0 Then
        strDataRange = wksData.UsedRange.Address
    Else
        strDataRange = Range("DataRange")
    End If
    
    Set rngData = Application.Intersect(wksData.UsedRange, wksData.Range(strDataRange))
    
    varUniques = UNIQUEIF(rngData.Columns(lngSplitCol), 2)
    
    With Application
        .ScreenUpdating = 0
        .DisplayAlerts = 0
    End With
    
    If IsArray(varUniques) Then
        Select Case CLng(Application.Version)
            Case Is < 12
                If UCase$(strFileFormat) = ".XLS" Then
                    lngFileFormatNum = -4143
                ElseIf UCase$(strFileFormat) = ".CSV" Then
                    lngFileFormatNum = 6
                End If
            Case Else
                If UCase$(strFileFormat) = ".XLS" Then
                    lngFileFormatNum = 56
                ElseIf UCase$(strFileFormat) = ".CSV" Then
                    lngFileFormatNum = 6
                ElseIf UCase$(strFileFormat) = ".XLSX" Then
                    lngFileFormatNum = 51
                End If
        End Select
        On Error GoTo Xit
        With rngData
            For lngLoop = LBound(varUniques) To UBound(varUniques)
                Application.StatusBar = "Processing " & lngLoop & " of " & UBound(varUniques)
                If .Parent.FilterMode Then .Parent.ShowAllData
                .AutoFilter lngSplitCol, varUniques(lngLoop)
                Set rngToCopy = Nothing
                Set rngToCopy = .Resize(.Rows.Count, .Columns.Count).SpecialCells(12)
                If Not rngToCopy Is Nothing Then
                    Set wbkNewFile = Workbooks.Add(-4167)
                    rngToCopy.Copy wbkNewFile.Worksheets(1).Range("a1")
                    NewFileName = wbkNewFile.Worksheets(1).Range("a2")
                    If Not blnSplitAllCol Then
                        For lngLoopCol = UBound(varCols) To 0 Step -1
                            wbkNewFile.Worksheets(1).Columns(CLng(varCols(lngLoopCol))).Delete
                        Next
                    End If
                    wbkNewFile.SaveAs strOutPutFolder & NewFileName & strFileFormat, lngFileFormatNum
                    wbkNewFile.Close
                    Set wbkNewFile = Nothing
                End If
            Next
            .AutoFilter
            MsgBox "Done !!", vbInformation, Ttle
        End With
    End If
Xit:
    With Application
        .StatusBar = False
        .ScreenUpdating = 1
        .DisplayAlerts = 1
    End With
    If Not wbkNewFile Is Nothing Then
        wbkNewFile.Close 0
        Set wbkNewFile = Nothing
    End If
    
End Sub

[pesteness]

Thank you so much.