Dividir o arquivo excel como por valor de célula

1

Eu tenho um arquivo com mais de 100000 recodes. Eu quero dividir o arquivo de acordo com o valor da célula. Por exemplo, Na coluna A eu tenho SOLID, quero dividir o arquivo de acordo com o SOLID e salvar no nome de SOLID. Também é necessário o título em cada arquivo que é spitted.

Exemplo

SOLID  CLIENTID   NAME    CLIENT_TYPE  STATUS
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
    
por sushil 13.06.2013 / 13:27

1 resposta

1

Pelo que entendi, você tem uma planilha que, na primeira coluna, contém valores aos quais as linhas de dados são atribuídas. Você deseja isolar as linhas atribuídas a cada um desses valores e salvar as linhas de cada valor em uma planilha separada. Eu estou supondo que você queira evitar fazer isso manualmente, dado o número de recodificações que você mencionou.

O código VBA a seguir pode atender às suas necessidades. Ele inclui um procedimento que aplica valores de filtro a uma tabela do Excel e salva os resultados em pastas de trabalho individuais, bem como uma função de utilitário que identifica os valores exclusivos que precisam ser filtrados.

   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

        '*********************************************
        ' SET THE SAVE DIRECTORY AND FILE PREFIX HERE
        '*********************************************
        saveDir = "e:\"
        saveNamePrefix = "FILE"
        '*********************************************

        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set lastcell = Cells.Find(What:="*", After:=[A1], _
            SearchDirection:=xlPrevious)
        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
                .ShowAllData
                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
                .Select
                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
                wb.Close
            Else                                                     'Deal with existing files, if any
                msgResponse = MsgBox("File " & saveNamePrefix & _
                              resultArr(resultIndex) & _
                              ".xlsx already exists." & vbCrLf & _
                              "Replace the existing file?", _
                              vbYesNoCancel)
                If msgResponse = vbYes Then
                    Application.DisplayAlerts = False
                    wb.SaveAs savePathAndName
                    wb.Close
                    Application.DisplayAlerts = True
                Else
                    Application.DisplayAlerts = False
                    wb.Close
                    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
        ws.Range("A1").Select
        Exit Sub

    ExitErr:
        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
    
por 15.06.2013 / 03:10