Разбивка файла на части по значениям

[Bzik666]

Всем доброго времени суток.
Интересует такой вопрос. Как сделать разбивку файла Excel на части по значениям из столбца. Во вложенном файле находится структура файла. Необходимо сделать разбивку по столбцу Код ОУ. Например там идут значения 0001, 0002, 0002, 0003 и соответственно должно делиться на файлы 0001.xls, 0002.xls и т.д.
Заранее спасибо.

[Bzik666]

файл со структурой

[Hugo121]

Конкретно пальцем покажите - где "там идут значения 0001, 0002, 0002, 0003"

[staniiislav]

1) еще интересует код (0001) встречается только один раз или несколько раз?
2) должна копироваться строка с кодом (0001) или диапазон?

[staniiislav]

смотрите пример:

Sub Разрезать_по_файлам()
    Dim vItem, avArr, x, li As Long, i As Long, j As Long, n As Long, ce As Long
    Application.ScreenUpdating = False
    ce = Cells(Rows.Count, "C").End(xlUp).Row
    ReDim avArr(1 To ce, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("C2", Cells(Rows.Count, "C").End(xlUp)).Value
        'Cells(Rows.Count, 1).End(xlUp) - определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    'If li Then [E2].Resize(li).Value = avArr
    
    x = Range("A1", "AD" & ce).Value
    Fname = ThisWorkbook.Path
    MkDir Fname
    For i = 1 To UBound(avArr)
        For j = 1 To UBound(x)
            If IsEmpty(avArr(i, 1)) Then Exit For 
            If x(j, 3) = avArr(i, 1) Or x(j, 3) = "код ОУ" Then
                n = n + 1
            End If
        Next j
        If n > 0 Then
            Workbooks.Add xlWBATWorksheet
            [A1].Resize(n, 30).Value = x
            ActiveWorkbooks.Name = avArr(i, 1)
            ActiveSheet.Name = avArr(i, 1) ' поправбте в файле эту строку (было activesheets.Name)
            Set wb = ActiveWorkbook
            With wb
                .SaveAs Fname & "\" & avArr(i, 1) & ".xls", xlNormal 'FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                .Close
            End With
            n = 0
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

вот этот код:

    Dim vItem, avArr, x, li As Long, i As Long, j As Long, n As Long, ce As Long
    Application.ScreenUpdating = False
    ce = Cells(Rows.Count, "C").End(xlUp).Row
    ReDim avArr(1 To ce, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In Range("C2", Cells(Rows.Count, "C").End(xlUp)).Value
        'Cells(Rows.Count, 1).End(xlUp) - определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    'If li Then [E2].Resize(li).Value = avArr

взял из примера (Поиск уникальных значений) The_Prist
http://www.excel-vba.ru/chto-umeet-e...sya-znachenij/

[Bzik666]

Сообщение от staniiislav

1) еще интересует код (0001) встречается только один раз или несколько раз?
2) должна копироваться строка с кодом (0001) или диапазон?

код может встречаться несколько раз.
должен копироваться диапазон с данным кодом.

Ваш код опробовал. файлы создаются, но пустые. Не подскажете что нужно исправить?

И было бы идеально, если бы можно было выбирать файл для разбивки

[staniiislav]

Ваш код опробовал. файлы создаются, но пустые. Не подскажете что нужно исправить?

так вы таблицу дали пустую, мне даже пришлось самому целых два кода написать (0001, 0002 )

И было бы идеально, если бы можно было выбирать файл для разбивки

а вот это условия было указанно не корректно!!!
Это в корни меняет макрос... давайте файлы с нормальными примерами, будет время посмотрю

[Bzik666]

могу кусочек файла дать=)

[staniiislav]

а файлы в которые должна копироваться информация где?
а теперь конкретика, как вы хотите чтобы данные сохранялись в нужные вам файлы?
варианты:
1) файлы заранее открыты, и в них копируется информация (копирование будет происходить по названию файла, то есть если код 0001 соответствует названию книги 0001 и листа 0001, то данные будут скопированы)
- дополняется
- заменяется
2) выводилось сообщение какой сейчас обработался код, затем выводилось окно для выбора файла куда сохранять данные
- дополняется
- заменяется
3) ну и создание новых файлов (вариант который уже сделан)

[Bzik666]

Сообщение от staniiislav

а файлы в которые должна копироваться информация где?
а теперь конкретика, как вы хотите чтобы данные сохранялись в нужные вам файлы?
варианты:
1) файлы заранее открыты, и в них копируется информация (копирование будет происходить по названию файла, то есть если код 0001 соответствует названию книги 0001 и листа 0001, то данные будут скопированы)
- дополняется
- заменяется
2) выводилось сообщение какой сейчас обработался код, затем выводилось окно для выбора файла куда сохранять данные
- дополняется
- заменяется
3) ну и создание новых файлов (вариант который уже сделан)

Вариант который сделан. Копирование всех заполненных столбцов в новые файлы.