Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Как вставить скопированные данные по условию в 1 из N кол-ва книг VBA, Скопировать строку в книгу в зависимости от значения первой ячейки строки
 
Добрый день!
Есть файл с позициями, первый столбец которого показывает к какому поставщику относится товар.
Задача разбить все эти товары на отдельные файлы по названию поставщика, соответственно в каждом файле должны быть товары конкретного поставщика.
Подскажи, как через VBA копировать/вставлять строки в нужный файл в зависимости от названия в ячейке.

Немножко "накалякал" сам, но что-то мне кажется не в том русле плыву, макрос тренировочный, до конца не работает.
Код
Public Sub group()
Dim i As Integer, a As Integer
Dim book As Workbook
Dim book_name As String

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    
    Set book = Workbooks.Add
    book_name = ThisWorkbook.Sheets(1).Cells(i, 1)
    book.SaveAs Filename:=book_name
    
    ThisWorkbook.Activate
    Rows(1).Select
    Selection.Copy
    book.Activate
    book.Sheets(1).Rows(1).Select
    Sheets(1).Paste
     
        For a = 2 To ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
            If ThisWorkbook.Sheets(1).Cells(a, 1).Value = book_name Then
            ThisWorkbook.Activate
            ThisWorkbook.Sheets(1).Rows(a).Select
            Selection.Copy
            book.Activate
            book.Sheets(1).Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select
            ActiveSheet.Paste
            End If
        Next a
Next i
End Sub

Пример во вложении.

Спасибо.
Изменено: OblivionR - 18 Апр 2019 18:49:35
 
Ну чего никто не отвечает?(
 
А вы понимаете в своем коде , что сделали? Поищите по форуму тут куча примеров с решением вашей задачи.
Для начала нужно создать список поставщиков, с помощью либо коллекции либо словаря. Затем циклом по коллекции (словарю) -  либо через фильтр копируя отфильтрованное вставлять н в новую книгу, либо по массиву сравнивая создавать под массивы и выкладывать на лист вновь созданной книги, которую сохраняете с вставленными данными и закрываете. Можно так же через SQL запрос, но думаю , что это не Ваш вариант, хотя на форуме, где то и такой есть.
Изменено: Nordheim - 19 Апр 2019 12:33:06
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, спасибо за алгоритм, такого ответа я и ждал, макрос написал, все работает.
Кому интересно -
Код
Public Sub group_2()
Dim MyCollection  As New Collection
Dim i As Integer, a As Integer, k As Integer, l As Integer
Dim book As Workbook
Dim book_name As String

Application.ScreenUpdating = False
On Error Resume Next

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    MyCollection.Add Cells(i, 1).Value, Cells(i, 1).Value
Next i

Application.DisplayAlerts = 0
For i = 1 To MyCollection.Count
    Workbooks.Add.SaveAs Filename:=ThisWorkbook.Path & "\" & MyCollection.Item(i)
        For a = 1 To ThisWorkbook.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
            ActiveWorkbook.Sheets(1).Cells(1, a) = ThisWorkbook.Sheets(1).Cells(1, a)
        Next a
Next i
For i = 2 To ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    book_name = ThisWorkbook.Sheets(1).Cells(i, 1).Value
        l = Workbooks(book_name & ".xlsx").Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        Workbooks(book_name & ".xlsx").Sheets(1).Cells(l + 1, 1) = ThisWorkbook.Sheets(1).Cells(i, 1)
            
            For k = 1 To ThisWorkbook.Sheets(1).Cells(i, Columns.Count).End(xlToLeft).Column
            Workbooks(book_name & ".xlsx").Sheets(1).Cells(l + 1, k + 1) = ThisWorkbook.Sheets(1).Cells(i, k + 1)
            Next k
            Workbooks(book_name & ".xlsx").Sheets(1).Columns.EntireColumn.AutoFit
            
Next i
    For i = Workbooks.Count To MyCollection.Count + 1 Step -1
        Workbooks(i).Close True
    Next i
 
Application.ScreenUpdating = True
Application.DisplayAlerts = 1
End Sub
 
Цитата
OblivionR написал:
макрос написал, все работает
Что работает это хорошо, но при циклах беря данные с листа вы теряете в скорости, если будут большие объемы, но иакрос на массивах отработает в разы быстрее, убедился не раз на собственном опыте.
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
на массивах отработает в разы быстрее
А что конкретнее в этой задаче лучше вывести через массивы?
 
Цитата
OblivionR написал:
А что конкретнее в этой задаче лучше вывести через массивы?
Все.
"Все гениальное просто, а все простое гениально!!!"
 
По макросу:
1. Если нужна скорость, то подобные вещи
Код
Workbooks(book_name & ".xlsx").Sheets(1)

тоже стоит исключить. По возможности объявляйте дополнительную переменную листа, и ее используйте вместо полного названия, либо используйте хотя бы конструкцию with, что делает код более читабельным (имхо) и несколько ускоряет макрос.
2. Форматирование лучше вынести из цикла (autofit). Зачем каждый раз проделывать идентичную операцию, когда можно ее выполнить один раз за пределами циклов.
3. С циклами всегда работайте осторожно. Старайтесь убирать вложенность, где это только возможно. Если все таки вложенность нужна, старайтесь использовать конструкции vba: массивы, коллекции, словари и т.д. Они достаточно быстрые.
4. Ну и напоследок: если решили начать оптимизацию скорости через обновление экрана (screenupdating), то старайтесь
  • включать ручные вычисления (calculation);
  • использовать конструкции языка типа словари, коллекции, массивы и т.д.;
  • убирать любого рода выделения и активации (где это возможно) через методы select и activate;
  • уходить от новых переменных типа variant (для самодисциплины также используйте option explicit в самом начале модуля ВСЕГДА);
  • использовать двоеточие для объединения нескольких связанных строк в одну
С уважением,
Федор/Все_просто
Страницы: 1
Читают тему (гостей: 1)
Наверх