Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Разбить файл по содержимому ячейки (VBA)
 
#1
29.09.2013 20:46:44
Привет!!!
Прошу помощи, как при помощи VBA разбить книгу на несколько файлов в зависимости от того какое значение в пятой колонке таблицы?
Изменено: AlexVong - 30.09.2013 00:21:36
 
 
 
#2
29.09.2013 22:42:48
Находите уникальные значения в пятой колонке таблицы, их три.(ПР1/0898, ПР1/0900 и П220/0999)
Автофильтр по этим значениям и копирование видимых ячеек в другую книгу,
которую нужно создать.
Книгу называете по выборке из уникального значения.(898, 900 и 999)
Сохраняете книги.(Где их сохранять?)
Попробуйте записать эти действия макрорекордером
 
 
 
#3
29.09.2013 23:59:07
Код
Sub Разделить_по_книгам()
    Dim oDic As Object, arrData(), arrSeparateItems(), arrTemp(), i&, n&, m&, k&

    If MsgBox("Разделить данные по книгам?", vbQuestion + vbYesNo, "Вопрос") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    arrData() = Range("A1").CurrentRegion.Value
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = LBound(arrData) To UBound(arrData)
        If Not oDic.exists(arrData(i, 5)) Then oDic.Add arrData(i, 5), arrData(i, 5)
    Next i
    arrSeparateItems() = oDic.items
    For n = LBound(arrSeparateItems) To UBound(arrSeparateItems)
        ReDim arrTemp(1 To UBound(arrData), 1 To UBound(arrData, 2))
        k = 0
        For i = LBound(arrData) To UBound(arrData)
            If arrData(i, 5) = arrSeparateItems(n) Then
                k = k + 1
                For m = LBound(arrData, 2) To UBound(arrData, 2)
                    arrTemp(k, m) = arrData(i, m)
                Next m
            End If
        Next i
        Workbooks.Add
        Range("A1").Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
        Columns("A:E").AutoFit
        Columns("B:B").HorizontalAlignment = xlLeft
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Right(arrSeparateItems(n), 3), xlExcel8
        ActiveWorkbook.Close SaveChanges:=True
    Next n
    Application.ScreenUpdating = True
    MsgBox "Данные разделены и сохранены в " & ThisWorkbook.Path & "\", vbInformation, "Конец"
End Sub
 
 
 
#4
30.09.2013 18:52:54
Цитата
Workbooks.Add
 Range("A1" ;) .Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
 Columns("A:E" ;) .AutoFit
 Columns("B:B" ;) .HorizontalAlignment = xlLeft
Данные переносятся в книгу Оригинал Лист1,
Мне кажется надо сделать так
Код
        Workbooks.Add (xlWBATWorksheet)     'создать книгу с одним листом
        With ActiveSheet
            .Range("A1").Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
            .Columns("A:E").AutoFit
            .Columns("B:B").HorizontalAlignment = xlLeft
        End With
Изменено: Kuzmich - 30.09.2013 19:36:15
 
 
 
#5
30.09.2013 20:59:34
Думаю разницы нет, т.к. данные вставляются в активный лист новой книги, т.к. Workbooks.Add
 
 
 
#6
30.09.2013 21:07:57
У вас данные переносятся в книгу Оригинал Лист1, а созданные три файла пустые
 
 
 
#7
30.09.2013 23:19:38
Не может такого быть, я тестировал и создаются 3 файла с данными.
Вот мой файл. Сейчас ещё раз потестировал, создаются 3 файла с данными.
Попробуйте сами с моим файлом
 
 
 
#8
30.09.2013 23:33:22
Я ваш макрос вставлял в модуль листа1, поэтому и такой результат.
А, если макрос в модуле книги, то все в порядке.
 
 
 
#9
30.09.2013 23:36:45
tester
Спасибо!!! Все работает отлично!
 
 
 
#10
01.10.2013 01:31:13
Не очень быстрый
Код
Sub Split_to_Box()
Dim Unik: Set Unik = CreateObject("Scripting.Dictionary")
Dim i&, Kei$, a
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Лист1")
For i = 1 To .Cells(Rows.Count, 5).End(xlUp).Row
    a = Split(.Cells(i, 5), "/")
    Kei = a(UBound(a))
    If Unik.Item(Kei) Then
        .Range(.Cells(i, 1), .Cells(i, 5)).Copy Worksheets(Kei).Cells(Unik.Item(Kei), 1)
        Unik.Item(Kei) = Unik.Item(Kei) + 1
    Else
        Sheets.Add After:=ActiveSheet
        ThisWorkbook.ActiveSheet.Name = Kei
        Unik.Item(Kei) = 1
        .Range(.Cells(i, 1), .Cells(i, 5)).Copy Worksheets(Kei).Cells(Unik.Item(Kei), 1)
    End If
 Next
Sheets(Unik.keys).Move
' Далее сохраняем куда нужно и как нужну.
' ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Right(arrSeparateItems(n), 3), xlExcel8
'        ActiveWorkbook.Close SaveChanges:=True
End With
Application.ScreenUpdating = True
End Sub
Изменено: Михаил С. - 01.10.2013 01:36:31
 
 
 
#11
01.10.2013 01:47:05
Упс.. не понял, что каждый лист в отдельную книгу. Тогда так:
Код
Sub Split_to_Box()
Dim Unik: Set Unik = CreateObject("Scripting.Dictionary")
Dim i&, Kei$, a, Arr
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Лист1")
For i = 1 To .Cells(Rows.Count, 5).End(xlUp).Row
    a = Split(.Cells(i, 5), "/")
    Kei = a(UBound(a))
    If Unik.Item(Kei) Then
        .Range(.Cells(i, 1), .Cells(i, 5)).Copy Worksheets(Kei).Cells(Unik.Item(Kei), 1)
        Unik.Item(Kei) = Unik.Item(Kei) + 1
    Else
        Sheets.Add After:=ActiveSheet
        ThisWorkbook.ActiveSheet.Name = Kei
        Unik.Item(Kei) = 1
        .Range(.Cells(i, 1), .Cells(i, 5)).Copy Worksheets(Kei).Cells(Unik.Item(Kei), 1)
    End If
 Next
 Arr = Unik.keys
 For i = 0 To UBound(Arr)
Sheets(Arr(i)).Move

' Далее сохраняем куда нужно и как нужно.
 ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Arr(i), xlExcel8
        ActiveWorkbook.Close SaveChanges:=True
Next
End With
Application.ScreenUpdating = True
End Sub
 
 
 
#12
25.12.2015 14:44:55
Можно еще в этот код заголовки столбцов добавить?
 
 
 
#13
25.12.2015 15:08:07
Цитата
Можно еще в этот код заголовки столбцов добавить?
Наверное можно, но за два года Михаил забыл и про код, и про тему :D
 
 
 
#14
25.12.2015 15:19:58
Это точно.
Заголовки, вероятно, добавить можно (если это вообще вопрос к моему коду), но в ближайшее время я этого сделать не смогу.
 
 
 
#15
25.12.2015 15:53:43
Да, к вашему коду вопрос.  :(
Я переделал под первый солбец, вместо пятого, и всего 40 стололбцов вместо 5, но не копируются заголовки.,
Код
Sub Split_to_Box()
Dim Unik: Set Unik = CreateObject("Scripting.Dictionary")
Dim i&, Kei$, a, Arr
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Ëèñò1")
For i = 1 To .Cells(Rows.Count, 40).End(xlUp).Row
    a = Split(.Cells(i, 1), "/")
    Kei = a(UBound(a))
    If Unik.Item(Kei) Then
        .Range(.Cells(i, 1), .Cells(i, 40)).Copy Worksheets(Kei).Cells(Unik.Item(Kei), 1)
        Unik.Item(Kei) = Unik.Item(Kei) + 1
    Else
        Sheets.Add After:=ActiveSheet
        ThisWorkbook.ActiveSheet.Name = Kei
        Unik.Item(Kei) = 1
        .Range(.Cells(i, 1), .Cells(i, 40)).Copy Worksheets(Kei).Cells(Unik.Item(Kei), 1)
    End If
 Next
 Arr = Unik.keys
 For i = 0 To UBound(Arr)
Sheets(Arr(i)).Move
 

 ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Arr(i), xlExcel8
        ActiveWorkbook.Close SaveChanges:=True
Next
End With
Application.ScreenUpdating = True
End Sub
 
 
 
#16
25.12.2015 16:09:41
Alexey200, покажите маленький пример вашего файла.
Может что-то получится.
 
 
 
#17
25.12.2015 16:15:58
Вот  
 
 
 
#18
25.12.2015 16:42:55
А чё пример без макроса?
Код
Sub Split_to_Box()
Dim Unik As Object
Set Unik = CreateObject("Scripting.Dictionary")
Dim i&, Kei$, C&, Arr
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Лист1")
    C = .Range("A1").End(xlToRight).Column
    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        Kei = .Cells(i, 1).Value
        If Unik.exists(Kei) Then
            .Range(.Cells(i, 1), .Cells(i, C)).Copy Worksheets(Kei).Cells(Unik.Item(Kei), 1)
            Unik.Item(Kei) = Unik.Item(Kei) + 1
        Else
            Sheets.Add After:=ActiveSheet
            ThisWorkbook.ActiveSheet.Name = Kei
            Unik.Item(Kei) = 2
            .Range(.Cells(1, 1), .Cells(1, C)).Copy Worksheets(Kei).Cells(1, 1)
            .Range(.Cells(i, 1), .Cells(i, C)).Copy Worksheets(Kei).Cells(Unik.Item(Kei), 1)
        End If
     Next
     Arr = Unik.keys
     For i = 0 To UBound(Arr)
    ThisWorkbook.Sheets(Arr(i)).Move
     
    ' Далее сохраняем куда нужно и как нужно.
     ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Arr(i), xlExcel8
            ActiveWorkbook.Close SaveChanges:=True
    Next
End With
Application.ScreenUpdating = True
End Sub
 
 
 
#19
25.12.2015 16:48:00
Первое почему
У вас слеш (/) в номере договора (столбец В), а в коде столбец А ?
Код
    a = Split(.Cells(i, 1), "/")
 
 
 
#20
25.12.2015 16:50:24
Забыл вставить код, спешил ))
Пробую ваш переделанный ))

Все работает!!! Спасибо!!!!!  :D
Изменено: Alexey200 - 25.12.2015 16:53:02
 
 
 
#21
25.12.2015 16:51:28
Kuzmich, я так понял, что нужно разбить по филиалам.
Во всяком случае я сделал по филиалам.
 
 
 
#22
25.12.2015 16:53:37
Цитата
Михаил С. написал:
Во всяком случае я сделал по филиалам.
все верно, все работает  :D
 
 
 
#23
25.12.2015 16:59:40
Цитата
что нужно разбить по филиалам
По коду я понял, что нужно разбить по номеру договора
 
 
 
#24
09.05.2019 21:08:59
Уважаемый, tester!
Очень помог Ваш код, указанный здесь: #3
Помогите доработать макрос:
1) чтобы копировалась первая строка таблицы - шапка - на каждый лист;
2) чтобы сохранялось форматирование данных из исходной таблицы.

Заранее благодарю! :)
 
 
 
#25
09.05.2019 21:15:00
1. Вопросы не по теме.
2. Эти два вопроса разной тематики.
 
 
 
Страницы: 1
Наверх