Page 2 of 2 FirstFirst 12
Results 11 to 13 of 13

Thread: Split data into separate file and save according to filename

  1. #11
    Junior Member
    Join Date
    Aug 2012
    Posts
    19
    Rep Power
    0
    Quote Originally Posted by pesteness View Post
    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
    .

  2. #12
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi,

    Try this code. Also type 1 in C6 on ControlSheet

    Code:
    '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
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  3. #13
    Junior Member
    Join Date
    Aug 2012
    Posts
    19
    Rep Power
    0
    Thank you so much.

Similar Threads

  1. Split Workbook into Separate Workbooks VBA
    By Admin in forum Download Center
    Replies: 12
    Last Post: 08-08-2018, 09:33 PM
  2. Replies: 34
    Last Post: 03-13-2015, 02:26 PM
  3. Save Worksheets As New File To Specific Folder
    By k0st4din in forum Excel Help
    Replies: 18
    Last Post: 06-08-2013, 04:24 PM
  4. Replies: 1
    Last Post: 03-07-2013, 11:42 AM
  5. Save File In CSV Format VBA
    By Raj Kumar in forum Excel Help
    Replies: 3
    Last Post: 06-01-2011, 07:22 AM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •