Take the 2-minute tour ×
Super User is a question and answer site for computer enthusiasts and power users. It's 100% free, no registration required.

I have file of more than 100000 recodes. I want to split the file as per the cell value. For e.g. in column A I have SOLID, I want to split the file as per the SOLID and save in the name of SOLID. Also required the heading in each file which is spitted.


1324   123455     PU      1            3
1324   12364453   HARI    1            1
1324   4242430    S       1            1
1324   242454     SANJ    1            1
1324   454144     LOVE    1            1
1325   44         ANJ     1            1
1325   4          SUN     1            1
1325   4          ANS     1            1
1325   54546      ROBI    1            1
1289   4646       MUNI    1            1
1289   454546     JAYA    1            1
1289   46464      RAMC    1            1
1289   4545       MAHES   1            1
share|improve this question
I suggest @Jerry Beaucaire –  pnuts Jun 13 '13 at 11:58
This is a question for StackExchange. You are definitely going to need a macro for this one. –  variant Jun 13 '13 at 16:03
@variant Actually I don't even understand the question. What does he want to do exactly ? (In fact there is not a single interrogation mark in the text.) –  Jo Bedard Jun 13 '13 at 16:39
you want to split as this example into 3 worksheets or three worbooks? one each 1324, 1325 and 1289? –  datatoo Jun 13 '13 at 19:21
My understanding is the same as datatoo's. –  variant Jun 13 '13 at 20:26

1 Answer 1

up vote 1 down vote accepted

As I understand your question, you have a worksheet that in the first column contains values to which your data rows are assigned. You want to isolate the rows that are assigned to each of those values and save the rows for each value to a separate worksheet. I am assuming you want to avoid doing this by hand, given the number of recodes that you mention.

The following VBA code may suit your needs. It includes a procedure that applies filter values to an Excel table and saves the results to individual workbooks, as well as a utility function that identifies the unique values that need to be filtered.

   Option Explicit

   Sub FilterTableAndSave()
        'Filters a data range on the values in the first
        '  column of the range and saves the filtered
        '  values to separate worksheets. The data range
        '  is assumed to start in cell A1 and have
        '  column header names in row 1 of the range.
        '  The workbooks are saved under names that begin with
        '  a specified prefix and end with the filter value,
        '  e.g., "FILEAcme Corporation". The directory to which
        '  the files are saved and the file prefix must be specified
        '  below.

        Dim wb As Workbook
        Dim ws As Worksheet, newWs As Worksheet
        Dim tableRng As Range, filterValuesRng As Range, lastcell As Range
        Dim saveDir As String, savePathAndName As String
        Dim msgResponse As String, saveNamePrefix As String
        Dim inputArr() As Variant, resultArr() As Variant
        Dim resultIndex As Long

        On Error GoTo ExitErr

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        saveDir = "e:\"
        saveNamePrefix = "FILE"

        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set lastcell = Cells.Find(What:="*", After:=[A1], _
        Set tableRng = Range("$A$1:" & lastcell.Address)
        Set filterValuesRng = Range("$A$2:$A$" & lastcell.Row)
        With ws
            On Error Resume Next                                          'Convert data range to table
            .ListObjects.Add(SourceType:=xlSrcRange, Source:=tableRng, _
            XlListObjectHasHeaders:=xlYes).Name = "Main"
            On Error GoTo ExitErr
        End With
        inputArr = filterValuesRng                                        'Assign filter column to array
        resultArr = GetDistinctElements(inputArr)
        For resultIndex = LBound(resultArr) To UBound(resultArr)                          'Loop through filter values
            With ws
                On Error Resume Next
                On Error GoTo ExitErr
                .ListObjects("Main").Range.AutoFilter _
                    Field:=1, Criteria1:="=" & resultArr(resultIndex)     'Set current filter value
                .ListObjects("Main").Range.Copy                           'Copy filtered rows
            End With
            Set newWs = Workbooks.Add(xlWBATWorksheet).Worksheets(1)      'Create new workbook and
            On Error Resume Next                                          'paste filtered rows into it
            With newWs.Range("A1")
                .PasteSpecial xlPasteColumnWidths
                .PasteSpecial xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False
            End With
            On Error GoTo ExitErr
            Set wb = ActiveWorkbook                                       'File save routine
            savePathAndName = saveDir & saveNamePrefix & _
                              resultArr(resultIndex) & ".xlsx"
            If Dir(savePathAndName) = "" Then
                wb.SaveAs savePathAndName
            Else                                                     'Deal with existing files, if any
                msgResponse = MsgBox("File " & saveNamePrefix & _
                              resultArr(resultIndex) & _
                              ".xlsx already exists." & vbCrLf & _
                              "Replace the existing file?", _
                If msgResponse = vbYes Then
                    Application.DisplayAlerts = False
                    wb.SaveAs savePathAndName
                    Application.DisplayAlerts = True
                    Application.DisplayAlerts = False
                    Application.DisplayAlerts = False
                End If
            End If
        Next resultIndex
        ws.ShowAllData                                              'Convert data table back to range
        ws.ListObjects("Main").Unlist                               'and remove formatting
        With tableRng
            .Borders(xlEdgeLeft).LineStyle = xlNone
            .Borders(xlEdgeTop).LineStyle = xlNone
            .Borders(xlEdgeBottom).LineStyle = xlNone
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
            .Font.Bold = False
            With .Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        End With
        Exit Sub

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .DisplayAlerts = True
        End With
        Set ws = Nothing
        Set newWs = Nothing
        MsgBox "Error " & Err.Number & ": " & Err.Description, vbOKOnly, "Error"
    End Sub

    Function GetDistinctElements(ByRef inputArr)
        'returns a 1-D array of unique items from an N-by-2
        '  input array of data items with duplicates.
        '  The input array would normally be generated by
        '  assigning a single-column worksheet range to
        '  a Variant array.

        Dim dict As Object
        Dim i As Long
        Set dict = CreateObject("Scripting.Dictionary")
        For i = LBound(inputArr) To UBound(inputArr)
            dict(inputArr(i, 1)) = 1
        Next i
        GetDistinctElements = dict.Keys()

    End Function
share|improve this answer
Its working perfectly, thank you very much..... –  sushil Jun 17 '13 at 5:19
@sushil If this meets your needs you might mark this as a solution that worked for you. –  datatoo Jun 17 '13 at 18:22

Your Answer


By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.