Блог

Я пытаюсь взять один основной документ и разделить его на отдельные файлы Excel на основе значений в моем столбце «Бизнес-единица». Новые листы будут названы в честь их бизнес-единицы, и они должны содержать только данные в строках, содержащих эту конкретную бизнес-единицу. Т.Е. все строки с метками ACH должны находиться в новой папке ach. В настоящее время этот код создает листы на основе сегмента «столбец А». Он также предоставляет мне данные только в тех строках, которые соответствуют имени сегмента, т. Е. Вместо того, чтобы получать ACH ACH и ACH ACH 1 ACH ACH2, я просто получаю ACH ACH.Итак, я либо неправильно настроил фильтрацию, либо неправильно настроил копирование. Я просто не могу сказать.

 Sub ExtractToNewWorkbook()

    Dim ws     As Worksheet
    Dim wsNew  As Workbook
    Dim rData  As Range
    Dim rfl    As Range
    Dim Business_Unit  As String
    Dim sfilename As String

    Set ws = ThisWorkbook.Sheets("All Functions Final")

    'Apply advance filter in sheet

    With ws

        Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 10).End(xlUp))
        .Columns(.Columns.Count).Clear
        .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True


        For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))

            Business_Unit = rfl.Text

            Set wsNew = Workbooks.Add

            sfilename = Business_Unit amp; ".xlsx"

            'Set the Location

            ActiveWorkbook.SaveAs ThisWorkbook.Path amp; "" amp; sfilename
            Application.DisplayAlerts = False
            ws.Activate
            rData.AutoFilter Field:=2, Criteria1:=Business_Unit
            rData.Copy
            Windows(Business_Unit).Activate
            ActiveSheet.Paste
            ActiveWorkbook.Close SaveChanges:=True

        Next rfl

        Application.DisplayAlerts = True

    End With

    ws.Columns(Columns.Count).ClearContents
    rData.AutoFilter

End Sub