Привет всем! Посоветовали ваш форум как очень отзывчивый и добрый. У меня есть задача создать макрос. Макрос должен уметь фильтровать данные в одном столбце и сохранять по этой выборке в отдельные файлы Приложил файл, там есть столбец "Продукт", в нем содержатся продукты "Сыр Огурец Шоколад" и тд, по исполнению Макроса в папке с файлом должны оказаться Файлы с именами "Огурец" "Сыр" "Томат" и тд, а так же кто купил по какой цене и какой уникальный номер этой покупки, если честно я в ступоре, помогите умницы и умники =D
pympyy, Действительно, помогающий тут и отзывчивые и добрый и по мнению модераторов, даже слишком и уменя есть сомнения что название темы соответстветует содержанию запроса. Вы не рассматриваете что можно сделать набор файлов со сводной ссылающейся на приложенный файл, фильтр по продукту даст результат и обновление автоматическое? .
Здравствуйте, в какую сторону копать? Создать файлы с нужными названиями и потом указать что по названиям применять фильтр? Подойдет любое решение вопроса лишь был искомый результат
Некогда доделывать, но вот пока схематично, если кому интересны словарь с коллекциями:
Код
Option Explicit
Sub tt()
Dim d As Object, a, i&, t$, el, col
a = ActiveSheet.UsedRange.Columns(2).Value
Set d = CreateObject("scripting.dictionary")
For i = 2 To UBound(a)
t = a(i, 1)
If Not d.exists(t) Then d.Add t, New Collection
d.Item(t).Add i
Next
For Each el In d.keys
Debug.Print "Открываем файл для " & el
Debug.Print "копируем шапку"
For Each col In d.Item(el)
Debug.Print "копируем строки " & col
Next
Debug.Print "Сохраняем файл " & el
Next
End Sub
Sub RaznestiDannye()
Dim i As Long
Dim n As Long
Dim Criterij As String
Dim iName As String
Dim WCur As Worksheet
Dim WbN As Workbook
Dim AutoFilter As AutoFilter
Application.ScreenUpdating = False
Set WCur = ThisWorkbook.Worksheets("Лист1")
'отбор уникальных значений столбца B в столбец H
Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
, CopyToRange:=Range("H1"), Unique:=True
'количество уникальных значений продуктов
n = Cells(Rows.Count, 8).End(xlUp).Row
For i = 2 To n 'цикл по уникальным значениям
Criterij = Cells(i, 8)
iName = Criterij 'имя новой книги
'создаем новую книгу с одним листом
Set WbN = Workbooks.Add(xlWBATWorksheet)
'ставим автофильтр по столбцу B
WCur.Range("A1").CurrentRegion.AutoFilter 2, Criterij
'копируем видимые строки в новую книгу
WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1")
WCur.AutoFilter.Range.AutoFilter
WbN.Sheets("Лист1").Columns("A:D").AutoFit
WbN.Sheets("Лист1").Columns("H").Delete
WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
WbN.Close SaveChanges:=True
Next
Application.ScreenUpdating = True
End Sub
Kuzmich, Здравствуйте! Отлично работает на примере, но когда переношу в свой файл, меняю буквы на нужные, вываливается ошибка 400, вот просто 400 и все, решения в интернете не нашел =(
Kuzmich, Если вам не сложно дайте пожалуйста комментарии к коду где что применяется, непонятно откуда взялась цифра 2 в строке 12 "(Rows.Count, 2)" ну и в строке 17 что за 8 такая "Criterij = Cells(i, 8)" Уверен что я делаю ошибку в них, потому что внимательно изучил где что нужно изменить
Kuzmich,а скажите пожалуйста есть ли у этого кода какие-нибудь ограничения? к примеру пустые строки или обьединенные ячейки? все еще долбаюсь с этим кодом, заработало вроде но не на моем нужном документе =(