Есть прайс, требуется разделить его на разные листы, но по категориям которые указаны в столбце B. Желательно, чтобы листы назывались как и категории в столбце B. Как это можно реализовать? Спасибо.
Вариантов несколько можно ручками поковырять, можно с помощью VBA, с PQ не знаком, но думаю что можно и с помощью этой надстройки (хотя не факт). Первые 2 варианта однозначно рабочие, т.е. выполнимые. А по ссылке это вы можете смотреть свои файлы, но у меня, например, доступ к таким ресурсам закрыт. Поэтому потрудитесь сделать небольшой файл пример и прикрепить к сообщению, вероятнее всего в этом случае, и помощь придет намного быстрей.
Не только можно. Но уже столько раз реализовалось, что аж скучно писать снова. Я обычно делаю это AdvancedFilter'ом. Копирую лист, фильтрую в новое место, удаляю исходные данные.
Это поле фильтра сводной таблицы. Если его удалить, то фильтр отключится. Выделите все нужные листы -> Выделите строки, которые хотите скрыть -> ПКМ на выделенных строках -> Скрыть
Цитата
Deaviarat написал: И в столбце А должно быть название которое указано в исходнике в столбце B
это уж сами исправляйте в сводной как вам удобнее
Цитата
StoTisteg написал: Я обычно делаю это AdvancedFilter'ом.
Про варинант с расширенным фильтром посмотрите в Приёмах
Deaviarat написал: Если не затруднит можете на примере показать.
Прямо, в лоб и без оптимизации:
Код
Sub DivEtImp()
Dim Cats As Collection
Dim i As Long, cl As Long, rw As Long
Dim Cat As Variant
Dim ShNam As String
Application.ScreenUpdating = False
With Worksheets(1)
cl = .Cells(1, Columns.Count).End(xlToLeft).Column
rw = .Cells(Rows.Count, 2).End(xlUp).Row
Worksheets.Add after:=Worksheets(Sheets.Count)
.Columns(2).Copy Destination:=Columns(1)
End With
Cells.RemoveDuplicates Columns:=1, Header:=xlYes
Set Cats = New Collection
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Cats.Add Cells(i, 1).Value
Next i
Application.DisplayAlerts = False
Worksheets(Sheets.Count).Delete
For Each Cat In Cats
Worksheets(1).Copy after:=Worksheets(Sheets.Count)
ShNam = IIf(Len(Cat) > 31, Left(Cat), Cat)
ActiveSheet.Name = ShNam
Cells(1, 2).Copy Destination:=Cells(1, cl + 2)
Cells(2, cl + 2).Value = Cat
Range(Cells(1, 1), Cells(rw, cl)).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Range(Cells(1, cl + 2), Cells(2, cl + 2)), copytorange:=Cells(1, cl + 4)
Range(Columns(1), Columns(cl + 3)).Delete
Columns(2).Delete
Range(Columns(1), Columns(cl - 1)).EntireColumn.AutoFit
Next Cat
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub test()
' ---------------------------------------
Dim iConnection As ADODB.Connection
Dim iRecordset As ADODB.Recordset
Dim book As Workbook, sht As Worksheet
Dim coll As Collection, iPath$, i&, arr()
Dim isht As Worksheet, ikey, cnct$, iSelect$
Dim iColumnName$
' ---------------------------------------
Set coll = New Collection
Set iConnection = New ADODB.Connection
Set iRecordset = New ADODB.Recordset
Set book = ThisWorkbook
Set sht = book.Worksheets("Лист1")
iPath = ThisWorkbook.Path & Application.PathSeparator & book.Name
cnct = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & ";Extended Properties='Excel 12.0;HDR=YES';"
iConnection.ConnectionString = cnct
iColumnName = sht.[b1].Value
On Error Resume Next
For i = 2 To sht.Range("b" & sht.Rows.Count).End(xlUp).Row
With sht
coll.Add .Range("b" & i).Value, .Range("b" & i).Value
End With
Next i
On Error GoTo 0
Application.ScreenUpdating = False
For Each ikey In coll
iConnection.Open
iSelect = "SELECT * FROM [" & sht.Name & "$] WHERE [" & iColumnName & "]= '" & ikey & "'"
iRecordset.Open iSelect, iConnection
Set isht = Worksheets.Add(after:=sht)
With isht
.Name = Left(ikey, 30)
sht.Rows(1).Copy .Rows(1)
.Range("a2").CopyFromRecordset iRecordset
.Columns.AutoFit
End With
iConnection.Close
Next ikey
Application.ScreenUpdating = True
MsgBox "Готово!"
End Sub
"Все гениальное просто, а все простое гениально!!!"
Sub DivEtImp()
Dim Cats As Collection
Dim i As Long, cl As Long, rw As Long
Dim Dic As Object
Dim ShNam As String
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
With Worksheets(1)
cl = .Cells(1, Columns.Count).End(xlToLeft).Column
rw = .Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
Dic.Add Key:=.Cells(i, 2).Value, Item:=""
Next i
End With
Application.ScreenUpdating = False
With Dic
For i = 0 To .Count - 1
Worksheets(1).Copy after:=Worksheets(Sheets.Count)
ShNam = IIf(Len(.Keys()(i)) > 31, Left(.Keys()(i), 31), .Keys()(i))
ActiveSheet.Name = ShNam
Cells(1, 2).Copy Destination:=Cells(1, cl + 2)
Cells(2, cl + 2).Value = .Keys()(i)
Range(Cells(1, 1), Cells(rw, cl)).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Range(Cells(1, cl + 2), Cells(2, cl + 2)), copytorange:=Cells(1, cl + 4)
Range(Columns(1), Columns(cl + 3)).Delete
Columns(2).Delete
Range(Columns(1), Columns(cl - 1)).EntireColumn.AutoFit
Next i
End With
Application.ScreenUpdating = True
End Sub
Nordheim, дело вкуса... Код в принципе не совсем допиленный, например, Dim Cats As Collection там от старого варианта осталось. А так я в первом варианте предпочитаю циклы со счётчиком юзать, а ну как индекс внутри цикла ВНЕЗАПНО понадобится.
'это
Dim iConnection As ADODB.Connection
Dim iRecordset As ADODB.Recordset
'заменить на
Dim iConnection As Object
Dim iRecordset As Object
'и
' это
Set iConnection = New ADODB.Connection
Set iRecordset = New ADODB.Connection
'заменить на
Set iConnection = CreateObject("ADODB.Connection")
Set iRecordset = CreateObject("ADODB.Recordset")
"Все гениальное просто, а все простое гениально!!!"
Можно переменную счетчик вписать в цикл, просо где то слышал при больших объемах цикл For Each ... Next предпочтительней цикла For ... Next. Вссе дело в скорости.
"Все гениальное просто, а все простое гениально!!!"
Посмотрите чему равно значение переменной ikey возможно в значении есть недопустимые символы указанные в сообщении. Останов не на листе "Средства защиты" а на том который должен быть следующим. На самом деле, код писал с применением SQL запроса, потому что, аналогичный с использованием коллекций и словарей уже можно написать на автомате не особо вдумываясь (скучно ), хотелось как то разнообразить варианты выполнения задачи
Мотя, покажите содержимое того столбца, из которого Вы берёте имена листов. А для надёжности вместо
Код
.Name = Left(ikey, 30)
впишите
Код
Dim Bads(1 To 7) As String, Bad As Variant
Bads(1) = ":"
Bads(2) = "/"
Bads(3) = "\"
Bads(4) = "?"
Bads(5) = "*"
Bads(6) = "["
Bads(7) = "]"
For Each Bad In Bads
ikey = Replace(ikey, Bad, " ", 1, -1, vbTextCompare)
Next Bad
.Name = Left(ikey, 31)
Мотя написал: Это - понятно: следующий лист - это Листi, разумеется
Нет не так, сама система должна создать лист(i), а вот переименовать не может, потому что недопустимое значение переменной ikey для имени листа. Прикрепите файл.
Nordheim написал: Нет не так, сама система должна создать лист(i),
Похоже, я некорректно выразилась! Конечно, же - сама система создала лист(i)! _________________________________ А файл - большой! В нем более 8 тыс. строк на Прайс-листе. Изменять файл - лениво!
Удалите все столбцы кроме того на основании которого формируются листы. Удалите дубликаты из оставшегося столбца, вся процедура займет не более 30-40 сек.
StoTisteg написал: Вы моё исправление из #25 вносили?
Тут главное исправление внести в нужное место, если внести перед формированием переменной с запросом, то данных никаких не будет. Лучше использовать дополнительную переменную типа.
Код
Dim shtname$
shtname=Replace(ikey,....... и т.д.)
.name = left(shtname,31)
"Все гениальное просто, а все простое гениально!!!"