1

У меня есть файл более 100000 перекодировок. Я хочу разделить файл в соответствии со значением ячейки. Например, в столбце AI есть SOLID, я хочу разделить файл в соответствии с SOLID и сохранить на имя SOLID. Также требуется заголовок в каждом файле, который сплит.

пример

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

1 ответ1

1

Насколько я понимаю ваш вопрос, у вас есть лист, который в первом столбце содержит значения, которым назначены ваши строки данных. Вы хотите изолировать строки, назначенные каждому из этих значений, и сохранить строки для каждого значения на отдельном рабочем листе. Я предполагаю, что вы хотите избежать этого вручную, учитывая количество кодов, которые вы упомянули.

Следующий код VBA может удовлетворить ваши потребности. Он включает процедуру, которая применяет значения фильтра к таблице Excel и сохраняет результаты в отдельных книгах, а также функцию утилиты, которая идентифицирует уникальные значения, которые необходимо отфильтровать.

   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

Всё ещё ищете ответ? Посмотрите другие вопросы с метками .