VBA: разделение файла Excel на основе категории в данных

Question

По сути, мы хотим создать код VBA, который автоматически создает рабочие книги для каждого типа хранилища (столбец / переменная в нашем наборе данных).

Например, у нас есть одна исходная рабочая книга со следующей таблицей:

Store   Seller    Item     Price
 A    | Youtube | Banana | 5,00 
 B    | Youtube | Apple  | 6,00 
 A    | Google  | Apple  | 7,00 
 C    | Google  | Pear   | 5,00 
 B    | Amazon  | Citron | 4,50 

Что мы хотим достичь с помощью кода VBA для приведенной выше таблицы, это три отдельные рабочие книги дляТип магазина A, B и C. Книга должна иметь название Тип магазина.Таким образом, это выглядело бы так:

~ A.xls ~
Store   Seller    Item     Price
 A    | Youtube | Banana | 5,00
 A    | Google  | Apple  | 7,00

~ B.xls ~
Store   Seller    Item     Price
 B    | Youtube | Apple  | 6,00 
 B    | Amazon  | Citron | 4,50 

~ C.xls ~
Store   Seller    Item    Price
 C    | Google  | Pear   | 5,00

У меня был очень грубый способ сделать это (см. Ниже), но не хватает нескольких вещей:

1. Эффективныйloop
2. Windows(“Map4”).Activate портит потенциальную петлю 101
3. И способ именования файла в соответствии с ‘Type of store’

---

Sub Macro1() 

    ActiveSheet.Range("$A$1:$A$8" & "$C$1:$C$8").AutoFilter Field:=2, 
    Criteria1:="aa"
    Workbooks.Add 

    Windows("Test_split file.xlsm").Activate 
    Range("A1:C8").Select 
    Selection.Copy 
    Windows("Map4").Activate 
    ActiveSheet.Paste 
    Application.CutCopyMode = False 

    ActiveWorkbook.SaveAs Filename:="C:\Users\bjprent\Documents\aa.xlsx", _ 
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
    ActiveWindow.Close 


    ActiveSheet.Range("$A$1:$C$8").AutoFilter Field:=2, Criteria1:="bb" 
    Workbooks.Add

    Windows("Test_split file.xlsx").Activate 
    Range("A1:C8").Select 
    Selection.Copy 
    Windows("Map4").Activate 
    ActiveSheet.Paste 
    Application.CutCopyMode = False 

    ActiveWorkbook.SaveAs Filename:="C:\Users\bjprent\Documents\bb.xlsx", _ 
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 
    ActiveWindow.Close 

End Sub

Заранее благодарю за любую помощь!:)

Answer 1

Подробности как комментарии в пределах.

Sub splitStores()

    Dim i As Long, k As Variant, stores As Object

    Set stores = CreateObject("scripting.dictionary")
    stores.comparemode = vbTextCompare

    With ThisWorkbook.Worksheets("sheet9")
        If .AutoFilterMode Then .AutoFilterMode = False

        'create unique list of stores
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            stores.Item(.Cells(i, "A").Value2) = vbNullString
        Next i

        'cycle through the stores
        For Each k In stores.keys

            'create a new active workbook with all records
            .Cells.Parent.Copy

            With ActiveWorkbook.Worksheets(1)

                'rename the worksheet
                .Name = k

                'setup the autofilter area
                With .Cells(1, 1).CurrentRegion

                    'filter to show anything but current store
                    .AutoFilter field:=1, Criteria1:="<>" & k

                    'delete all unrelated records
                    .Offset(1, 0).EntireRow.Delete

                    'turn filter off
                    .Parent.AutoFilterMode = False

                End With

                'save and close independent workbook
                .Parent.SaveAs Filename:=ThisWorkbook.Path & "\" & k, FileFormat:=xlOpenXMLWorkbook
                .Parent.Close savechanges:=False

            End With

        Next k

    End With
End Sub

Answer 2

Вот как это сделать вручную:

• Создание сводной таблицы
• Перетащите Тип магазина в Фильтры (поле страницы) район
• Перетащите Продавца и Предмет в область поля строк
• Перетащите цену в область значений
• Теперь нажмите на вкладку «Анализ» на ленте и выберите «Параметры», «Показать страницы фильтра отчетов».
• Выберите тип магазина и нажмите OK.