Разбивка одного файла на несколько - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Разбивка одного файла на несколько - Мир MS Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Разбивка одного файла на несколько

Разбивка одного файла на несколько

Дата: Четверг, 15.11.2012, 11:41 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

Здравствуйте!

Столкнулся с такой задачей - регулярно приходится разбивать один файл, включающий несколько поставщиков, на отдельные файлы для каждого из них.

Т.е., когда получается 5-6 вендоров, можно и руками все сделать, но дело доходит до 30 и более, что вгоняет в депрессию)

Может быть есть какой-либо способ автоматизировать процесс?

Пример во вложении:
2 листа, разбивка определеяется по столбцу "VENDOR",
т.е., в итоге должно быть столько файлов, сколько этих вендоров.
При этом, для каждого вендора заполняется и первый и второй лист.
Желательно, чтобы и названия файлов были по вендору.

Нашел на excelvba как создавать текстовые файлы с копированием, но неясно, как задавть имена файлов по номеру вендора и как выбирать данные, относящиеся только к определенному вендору.

Заранее благодарен.

К сообщению приложен файл: Example.xlsx (25.8 Kb)

Ответить

Дата: Четверг, 15.11.2012, 12:02 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

Сделать не сложно - Вам на планете уже подсказывали как. Но нудно...
И кстати я так и не увидел ответ на мой вопрос (может и был, но тему там я больше не вижу, "ушла за горизонт" sad

sad

):
вендоры на обоих листах строго синхронны? Можно их определять по одному листу, или для надёжности нужно просмотреть оба?

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Четверг, 15.11.2012, 13:46 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

я там ответил, просто вставил ваш ник, подумал там оппонента надо заводить:

Список всех возможных вендоров, в принципе, у меня есть.
По синхронности так - на втором листе все вендоры, а на первом часть из них.
Я не пойму, "фильтруете листы и отобранное копируете в созданную макрсом книгу" - это подразумевается, лично фильтрую каждый вендор и копирую сам, или это делает макрос?
Ящик пива - 1000р, в эквиваленте) Пивом, как бы, красивее, но как его доставлять)

Сообщение отредактировал backbeat - Четверг, 15.11.2012, 13:49

Ответить

Дата: Четверг, 15.11.2012, 14:03 | Сообщение № 4

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

По вендорам понятно, т.е можно брать из второго листа.
По фильтру - ну конечно это будет делать макрос.
Сколько всего строк обычно бывает в файлах?

Ну а пиво мы и сами купим smile

smile

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Четверг, 15.11.2012, 14:23 | Сообщение № 5

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

Ну, я в макросах не силен, специфика другая, только на уровне авто-записи, поэтому и спрашиваю, как это организовать)

Строк: до 1000 на первом листе и до 5000 на втором...

Ответить

Дата: Четверг, 15.11.2012, 14:34 | Сообщение № 6

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

Понятно.
Уже начал делать smile

smile

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Четверг, 15.11.2012, 15:24 | Сообщение № 7

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

Готово.

[vba]

Code

Sub tt()
        Dim twb As Workbook, wb As Workbook, a(), i&, el, cnt&
        Dim strDate$, SaveAsName$

        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Set twb = ThisWorkbook

        strDate = Format(Now, "yyyy/mm/dd_hh-mm-ss")
        SaveAsName = ThisWorkbook.Path & "\" & strDate

        a = twb.Sheets(2).UsedRange.Columns(2).Value
        With CreateObject("scripting.dictionary")
            .comparemode = 1
            For i = 2 To UBound(a): .Item(Trim(a(i, 1))) = 0&: Next
            For Each el In .keys
                cnt = cnt + 1
                Application.StatusBar = "Working with " & el & ", " & cnt & " of " & .Count
                Set wb = Workbooks.Add(1)
                With twb.Sheets(1).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(1).[a1]
                    .AutoFilter
                End With
                wb.Sheets.Add After:=wb.Worksheets(1)
                With twb.Sheets(2).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(2).[a1]
                    .AutoFilter
                End With

                wb.SaveAs SaveAsName & "_" & el & ".xls"    ', FileFormat:=xlExcel8
                wb.Close

            Next
        End With

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

[/vba]

Правда почему-то у меня под 2003 генерятся файлы под 3 мб. Дома ещё проверю - может локальный глюк...
P.S. глюк исправил - виноват был Ваш файл smile

smile

Код заменил.

Готово.

[vba]

Code

Sub tt()
        Dim twb As Workbook, wb As Workbook, a(), i&, el, cnt&
        Dim strDate$, SaveAsName$

        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Set twb = ThisWorkbook

        strDate = Format(Now, "yyyy/mm/dd_hh-mm-ss")
        SaveAsName = ThisWorkbook.Path & "\" & strDate

        a = twb.Sheets(2).UsedRange.Columns(2).Value
        With CreateObject("scripting.dictionary")
            .comparemode = 1
            For i = 2 To UBound(a): .Item(Trim(a(i, 1))) = 0&: Next
            For Each el In .keys
                cnt = cnt + 1
                Application.StatusBar = "Working with " & el & ", " & cnt & " of " & .Count
                Set wb = Workbooks.Add(1)
                With twb.Sheets(1).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(1).[a1]
                    .AutoFilter
                End With
                wb.Sheets.Add After:=wb.Worksheets(1)
                With twb.Sheets(2).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(2).[a1]
                    .AutoFilter
                End With

                wb.SaveAs SaveAsName & "_" & el & ".xls"    ', FileFormat:=xlExcel8
                wb.Close

            Next
        End With

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

[/vba]

Правда почему-то у меня под 2003 генерятся файлы под 3 мб. Дома ещё проверю - может локальный глюк...
P.S. глюк исправил - виноват был Ваш файл smile

smile

Код заменил.Hugo

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Сообщение отредактировал Hugo - Четверг, 15.11.2012, 15:37

Ответить

СообщениеГотово.

[vba]

Code

Sub tt()
        Dim twb As Workbook, wb As Workbook, a(), i&, el, cnt&
        Dim strDate$, SaveAsName$

        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Set twb = ThisWorkbook

        strDate = Format(Now, "yyyy/mm/dd_hh-mm-ss")
        SaveAsName = ThisWorkbook.Path & "\" & strDate

        a = twb.Sheets(2).UsedRange.Columns(2).Value
        With CreateObject("scripting.dictionary")
            .comparemode = 1
            For i = 2 To UBound(a): .Item(Trim(a(i, 1))) = 0&: Next
            For Each el In .keys
                cnt = cnt + 1
                Application.StatusBar = "Working with " & el & ", " & cnt & " of " & .Count
                Set wb = Workbooks.Add(1)
                With twb.Sheets(1).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(1).[a1]
                    .AutoFilter
                End With
                wb.Sheets.Add After:=wb.Worksheets(1)
                With twb.Sheets(2).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(2).[a1]
                    .AutoFilter
                End With

                wb.SaveAs SaveAsName & "_" & el & ".xls"    ', FileFormat:=xlExcel8
                wb.Close

            Next
        End With

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

[/vba]

Правда почему-то у меня под 2003 генерятся файлы под 3 мб. Дома ещё проверю - может локальный глюк...
P.S. глюк исправил - виноват был Ваш файл smile

smile

Код заменил.

Автор - Hugo
Дата добавления - 15.11.2012 в 15:24

Дата: Четверг, 15.11.2012, 15:39 | Сообщение № 8

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

у меня ругается на эту строчку:
a = twb.Sheets(2).UsedRange.Columns(2).Value

Ответить

Дата: Четверг, 15.11.2012, 15:41 | Сообщение № 9

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

Вероятно Ваш рабочий файл выглядит иначе, не так, как пример.
Кстати, я там код заменил - возьмите самую последнюю версию (их было 3 sad

sad

)

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

Дата: Четверг, 15.11.2012, 15:48 | Сообщение № 10

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

нет, я взял файл, который сюда прикрепил
первый лист:
PART_NO VENDOR SUMM PART_NAME_ENG PART_NAME_RUS
и второй:
PART_NO VENDOR ON_ORDER IN_TRANSIT ON_DOCK BACK_ORDER STOCK DMDA_01 DMDA_02 DMDA_03 DMDA_04 DMDA_05 DMDA_06 DMDA_07 DMDA_08 DMDA_09 DMDA_10 D MDA_11 DMDA_12 PART_NAME_ENG PART_NAME_RUS

Ответить

Дата: Четверг, 15.11.2012, 15:49 | Сообщение № 11

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

Так и я на нём делаю.
Вы вероятно код в модуль листа положили - а нужно в стандартный модуль!
Такая версия будет чуть быстрее и экономнее с памятью:

[vba]

Code

Sub tt()
        Dim twb As Workbook, wb As Workbook, a(), i&, el, cnt&
        Dim strDate$, SaveAsName$

        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Set twb = ThisWorkbook

        strDate = Format(Now, "yyyy/mm/dd_hh-mm-ss")
        SaveAsName = ThisWorkbook.Path & "\" & strDate

        With twb.Sheets(2)
            a = Intersect(.Range("B1").CurrentRegion, .UsedRange.Columns(2)).Value
        End With

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

            For Each el In .keys
                cnt = cnt + 1
                Application.StatusBar = "Working with " & el & ", " & cnt & " of " & .Count
                Set wb = Workbooks.Add(1)
                With twb.Sheets(1).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(1).[a1]
                    .AutoFilter
                End With
                wb.Sheets.Add After:=wb.Worksheets(1)
                With twb.Sheets(2).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(2).[a1]
                    .AutoFilter
                End With

                wb.SaveAs SaveAsName & "_" & el & ".xls"    ', FileFormat:=xlExcel8
                wb.Close

            Next
        End With

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

[/vba]

Так и я на нём делаю.
Вы вероятно код в модуль листа положили - а нужно в стандартный модуль!
Такая версия будет чуть быстрее и экономнее с памятью:

[vba]

Code

Sub tt()
        Dim twb As Workbook, wb As Workbook, a(), i&, el, cnt&
        Dim strDate$, SaveAsName$

        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Set twb = ThisWorkbook

        strDate = Format(Now, "yyyy/mm/dd_hh-mm-ss")
        SaveAsName = ThisWorkbook.Path & "\" & strDate

        With twb.Sheets(2)
            a = Intersect(.Range("B1").CurrentRegion, .UsedRange.Columns(2)).Value
        End With

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

            For Each el In .keys
                cnt = cnt + 1
                Application.StatusBar = "Working with " & el & ", " & cnt & " of " & .Count
                Set wb = Workbooks.Add(1)
                With twb.Sheets(1).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(1).[a1]
                    .AutoFilter
                End With
                wb.Sheets.Add After:=wb.Worksheets(1)
                With twb.Sheets(2).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(2).[a1]
                    .AutoFilter
                End With

                wb.SaveAs SaveAsName & "_" & el & ".xls"    ', FileFormat:=xlExcel8
                wb.Close

            Next
        End With

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

[/vba]

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Сообщение отредактировал Hugo - Четверг, 15.11.2012, 15:52

Ответить

СообщениеТак и я на нём делаю.
Вы вероятно код в модуль листа положили - а нужно в стандартный модуль!
Такая версия будет чуть быстрее и экономнее с памятью:

[vba]

Code

Sub tt()
        Dim twb As Workbook, wb As Workbook, a(), i&, el, cnt&
        Dim strDate$, SaveAsName$

        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Set twb = ThisWorkbook

        strDate = Format(Now, "yyyy/mm/dd_hh-mm-ss")
        SaveAsName = ThisWorkbook.Path & "\" & strDate

        With twb.Sheets(2)
            a = Intersect(.Range("B1").CurrentRegion, .UsedRange.Columns(2)).Value
        End With

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

            For Each el In .keys
                cnt = cnt + 1
                Application.StatusBar = "Working with " & el & ", " & cnt & " of " & .Count
                Set wb = Workbooks.Add(1)
                With twb.Sheets(1).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(1).[a1]
                    .AutoFilter
                End With
                wb.Sheets.Add After:=wb.Worksheets(1)
                With twb.Sheets(2).Range("B1")
                    .AutoFilter
                    .AutoFilter Field:=2, Criteria1:=el
                    Intersect(.CurrentRegion, .SpecialCells(xlCellTypeVisible)).Copy wb.Sheets(2).[a1]
                    .AutoFilter
                End With

                wb.SaveAs SaveAsName & "_" & el & ".xls"    ', FileFormat:=xlExcel8
                wb.Close

            Next
        End With

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

[/vba]

Автор - Hugo
Дата добавления - 15.11.2012 в 15:49

Дата: Четверг, 15.11.2012, 16:05 | Сообщение № 12

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

Все равно ругается на
With twb.Sheets(2)

я в модуль PERSONAL.XLSB закинул

Ответить

Дата: Четверг, 15.11.2012, 16:06 | Сообщение № 13

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

Ну тогда конечно - там в коде привязка к тому файлу, где код.
Сейчас переделаю.

Переделал - замените
Set twb = ThisWorkbook
на
Set twb = ActiveWorkbook
smile

smile

Упс, ещё

SaveAsName = ThisWorkbook.Path & "\" & strDate
на
SaveAsName = twb.Path & "\" & strDate

А то нагенерит файлов в папку автозапуска...

Или уже нагенерило? sad

sad

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Сообщение отредактировал Hugo - Четверг, 15.11.2012, 16:18

Ответить

Дата: Четверг, 15.11.2012, 16:19 | Сообщение № 14

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

офигительно! Только один нюанс, я так понимаю, что файлы создаются на основе второго листа, т.е. сколько на нем вендоров, столько и файлов. Можно завязать на вендоров первого листа, пжл?

Ответить

Дата: Четверг, 15.11.2012, 16:25 | Сообщение № 15

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

и, куда пиво залить? вебманей у меня нет, может на счет или телефон?

Ответить

Дата: Четверг, 15.11.2012, 17:13 | Сообщение № 16

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

Можно брать и с первого - меняете тут 2 на 1:

With twb.Sheets(1) '<- вот тут!!!
a = Intersect(.Range("B1").CurrentRegion, .UsedRange.Columns(2)).Value
End With

Можно и на счёт - если $ или € smile

smile

Но думаю перевод будет стОить дороже денег sad

sad

На телефон не годится - нет у меня такой возможности, на абонентке я.

P.S.
Хотя тут можно чуть упростить, чтоб "масло масляным" небыло:

[vba]

Code

    With twb.Sheets(1)
         a = .Range("B1").CurrentRegion.Columns(2).Value
     End With

[/vba]

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Сообщение отредактировал Hugo - Четверг, 15.11.2012, 17:17

Ответить

Дата: Четверг, 15.11.2012, 17:24 | Сообщение № 17

Группа: Пользователи

Ранг: Новичок

Сообщений: 14

Репутация: 0 ±

Замечаний: 0% ±

Спасибо! это прекрасно) сегодня попробую через терминал закинуть.

Ответить

Дата: Четверг, 15.11.2012, 18:08 | Сообщение № 18

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3691

Репутация: 790 ±

Замечаний: 0% ±

365

Ещё одна версия - чуть оптимальнее и короче код:

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD

Ответить

СообщениеЕщё одна версия - чуть оптимальнее и короче код:

Автор - Hugo
Дата добавления - 15.11.2012 в 18:08

Разбивка одного файла на несколько

Страница 1 из 1
1

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!