макрос в Excel

[MMMarinka]

Многоуважаемые умы!!!
Помогите с помощью макроса решить задачу - есть массив данных 40 000 строк и нужно разделить общей массив по принадлежности к территории и для каждой территории создать свой файл. Т.е. если к территории Москва относится 2000 строк, то все они попадут в этот новый файл с названием Москва. При этом скопируют все 3 рабочих листа из книги.
Очень !!!!надеюсь!!!! (не дайте надежде погибнуть!!!!!), что кто-то подскажет волшебный макрос а то так на деление файла уходят года
для примера могу и прикреплю!!! файлик)

[EducatedFool]

для примера могу прилепить файлик

если можете - что же не прилепили?

Без примера результата (и исходных данных) помощи вы вряд ли дождётесь

[MMMarinka]

Спасибо!!!!! Учла))
А вот и тот файл, который оооооочень нужно поделить на несколько по столбцу area..
Ну теперь помощь мимо не должна пройти...)

[EducatedFool]

Теперь все файлы с выборками создаются за минуту нажатием одной кнопки:



Вот код основного макроса:

Sub Main()
    On Error Resume Next
    folder$ = ThisWorkbook.Path & "\areas\": MkDir folder$    ' создаем папку для файлов

    Dim ra As Range: Set ra = shs.Range(shs.[A2], shs.Range("K" & shs.Rows.Count).End(xlUp))
    arr = ra.Value ' исходный массив данных

    ' ищем уникальные области в столбце D
    Dim Dra As Range: Set Dra = shs.Range(shs.[D2], shs.Range("D" & shs.Rows.Count).End(xlUp))
    
    For Each area In UniqueValues(Dra.Value)    ' для каждой области
        arr2 = "": arr2 = ArrAutofilterEx(arr, "4=" & area)  ' отбираем подходящие строки
        Filename$ = folder$ & area & ".xlsb"
        ra.ClearContents: Err.Clear
        ra.Rows(1).Resize(UBound(arr2)).Value = arr2
        If Err = 0 Then ActiveWorkbook.SaveCopyAs Filename$    ' сохраняем очередной файл
        Debug.Print "Файл " & area & ".xlsb" & IIf(Err = 0, " создан успешно", " не получилось создать")
    Next

    ra.Value = arr    ' восстанавливаем исходные данные
End Sub

Пример в файле: http://excelvba.ru/XL_Files/Sample__...2__0-24-05.zip
(СНАЧАЛА ИЗВЛЕКИТЕ ФАЙЛ ИЗ АРХИВА НА ДИСК, потом откройте файл, и запустите макрос CreateAreaFiles

В окне Immediate выводится результат:

Файл Moscow.xlsb создан успешно
Файл Saint-Petersburg.xlsb создан успешно
Файл Middle Volga-Orenburg.xlsb создан успешно
Файл Kama.xlsb создан успешно
Файл West Siberia.xlsb создан успешно
Файл Chernozemie.xlsb создан успешно
Файл Belomorie.xlsb создан успешно
Файл Tyumen and oblast.xlsb создан успешно
Файл Upper Volga.xlsb создан успешно
Файл Golden Ring-North.xlsb создан успешно
Файл Golden Ring-South.xlsb создан успешно
Файл Central Siberia.xlsb создан успешно
Файл Baltika.xlsb создан успешно
Файл South Ural.xlsb создан успешно
Файл Kazakhstan.xlsb создан успешно
Файл Kuzbass-Tomsk.xlsb создан успешно
Файл Kavkaz.xlsb создан успешно
Файл Kuban.xlsb создан успешно
Файл Tatarstan.xlsb создан успешно
Файл Western Far East.xlsb создан успешно
Файл Lower Volga.xlsb создан успешно
Файл Byelorussia.xlsb создан успешно
Файл Eastern Far East.xlsb создан успешно
Файл East Siberia.xlsb создан успешно

[MMMarinka]

многоуважаемый EducatedFool, ААА!!! выглядит великолепно 'подпрыгиваю до потолка!!!!
Спасибо огроменное!!!! годы жизни спасены! прикланяюсь перед великими знаниями!!!
завтра буду опробовать)!!!

[Hugo121]

Попробуйте так - создайте стандартный модуль, туда этот код, запускать по Alt+F8 или кнопкой на панели (нужно сделать):

Option Explicit

Sub Otbor()
    Dim a, i&, lRow, kk, rngFiltr As Range, wb As Workbook, sh As Worksheet
    Application.ScreenUpdating = False

    Set wb = Workbooks.Add(1)
    Set sh = wb.Sheets(1)
    ThisWorkbook.Sheets("точки").Activate

    With Sheets("точки")
        lRow = .Range("D" & .Rows.Count).End(xlUp).Row
        a = .Range(.Range("D1"), .Range("D" & lRow)).Value
    End With

    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            .Item(a(i, 1)) = 0&
        Next

        Set rngFiltr = Sheets("точки").Range("A1:K" & lRow)

        If Not Sheets("точки").AutoFilterMode Then rngFiltr.AutoFilter
        For Each kk In .keys
            sh.Cells.Clear
            rngFiltr.AutoFilter Field:=4, Criteria1:=kk
            Sheets("точки").Range("A1:K" & lRow).SpecialCells(xlCellTypeVisible).Copy sh.Cells(1, 1)
            Application.StatusBar = "Сохраняю файл " & kk
            wb.SaveAs ThisWorkbook.Path & "\" & kk
        Next
    End With

    wb.Close 0

    With Application
        .StatusBar = False
        .ScreenUpdating = True
    End With
End Sub

P.S. опоздал... Ну и ладно
Хотя нет - мне мой вариант нравится больше - см. скриншот

[MMMarinka]

Hugo121, миллион спасибо!!!! я очень благодарна!!!!! всеми способами сделаю! ни один способ не пострадает, все будут применены!!!!)

[Hugo121]

Кстати, я забыл/не заметил "При этом скопируют все 3 рабочих листа из книги"...
И кстати - а зачем их копировать - там ведь сводные по данным, которых по идее в файле быть не должно?
В общем, я задачу понял по-своему

[MMMarinka]

зачем копировать?!) - полноценный отчет по территории, в сводной можно покрутить в разных разрезах, а в на листе точки более детально рассмотреть)..идея такова)
Испекли один большой пирог, а затем разрезали для каждой 'территории)) со всей начинкой))

[Hugo121]

Тогда может так:

Option Explicit

Sub Otbor()
    Dim a, i&, lRow, kk, rngFiltr As Range, sh As Worksheet

    DoEvents
    Application.ScreenUpdating = False

    ThisWorkbook.Sheets(Array("pivot-общее кол-во точек", "pivot-тип и город")).Copy
    Set sh = ActiveWorkbook.Sheets.Add
    sh.Name = "точки"

    ThisWorkbook.Sheets("точки").Activate

    With Sheets("точки")
        lRow = .Range("D" & .Rows.Count).End(xlUp).Row
        a = .Range(.Range("D1"), .Range("D" & lRow)).Value
    End With

    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            .Item(a(i, 1)) = 0&
        Next

        Set rngFiltr = Sheets("точки").Range("A1:K" & lRow)

        If Not Sheets("точки").AutoFilterMode Then rngFiltr.AutoFilter
        For Each kk In .keys
            sh.Cells.Clear
            rngFiltr.AutoFilter Field:=4, Criteria1:=kk
            Sheets("точки").Range("A1:K" & lRow).SpecialCells(xlCellTypeVisible).Copy sh.Cells(1, 1)
            Application.StatusBar = "Сохраняю файл " & kk
            sh.Parent.SaveAs ThisWorkbook.Path & "\" & kk
        Next
    End With

    sh.Parent.Close 0

    With Application
        .StatusBar = False
        .ScreenUpdating = True
    End With
End Sub