Доброго всем. Подскажите где тут ошибка (пытаюсь перекрутить ранее подсказанный добрыми ребятами с этого форума под новые нужды) и как ее можно исправить чтобы по заданным наименованиям в столбце 7 начиная с сell(1,7) и до последней ячейки в столбце названия Сравнивались с текущими названиями листов в книге И Удалялись если не совпадают.
Код
iLastRow = Cells(3, 7).End(xlDown).Row ' последняя заполненная ячейка в столбце с именами листов
For i = 1 To iLastRow
If a = Worksheets("check").Cells(i, 7).Value Then
For Each Worksheet In ThisWorkbook.Sheets
If a <> Worksheet.Name Then
Worksheet.Delete
End If
On Error Resume Next
Next
i = i + 1
End If
On Error Resume Next
Next
Уххх сложно было, нон оно работает ^_^= ловите, может кому сгодиться.
Код
Dim s As Object, a As Variant, z As Integer, d As Boolean, zojberg As Variant
a = WorksheetFunction.Transpose(Worksheets("check").Range(Worksheets("check").Cells(1, 7), Worksheets("check").Cells(iLastRow, 7)))
Application.DisplayAlerts = False
For Each s In Sheets
d = True
For z = LBound(a) To UBound(a)
If s.Name = a(z) Then d = False
Next z
If d Then s.Delete
Next s
Application.DisplayAlerts = True
просто: из списка собрать словарь dicSheets (в ключи - sh.Names списка), потом цикл For Each sh in Thisworkbook.Sheets.. по листам ! с проверкой в словаре: If Not dicSheets.exists(sh.Name) Then sh.Delete -- примеров работы со словарями много на форуме -- CreateObject("Scripting.Dictionary") как-то так - более оптимально... а то вы в цикле на каждом листе заново запускаете цикл на просмотр массива - снова и снова... а при использовании словаря - будет только цикл по листам и проверка по ключу (сразу видит есть ли этот ключ-лист в "списке", т.е. в словаре ! созданном из списка)... успехов
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
JeyCi написал: просто: из списка собрать словарь dicSheets (в ключи - sh.Names списка),потом цикл For Each sh in Thisworkbook.Sheets.. по листам ! с проверкой в словаре:If Not dicSheets.exists(sh.Name) Then sh.Delete
Подскажите пожалуйста как это будет выглядеть в коде целиком, просто я пока только стараюсь учиться и далеко не все так легко с ходу могу понять что к чему........словари для меня тайная комната.........
Tesla_LOLa написал: я пока только стараюсь учиться
научитесь читать правила форума - в части "приложить файл"
Цитата
Tesla_LOLa написал: не все так легко с ходу могу понять что к чему........
поиск по форуму! И свои попытки - чтобы были понятны ваши затруднения... 2 раза не пишу о том, что примеров по словарям много... а так смахивает на "сделайте за меня"
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
Set d = CreateObject("Scripting.Dictionary"): d.comparemode = 1
......................
d.item(t) = .Cells(i, 7) & "|" & .Cells(i, 7)
про такие вещи как :
Скрытый текст
Код
Dim a(), mad As Object, mdd As Object, dvd As Object, kmd As Object
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
On Error GoTo err_
Select Case Target.Address(0, 0)
Case "G6": filldict
[h6:k6].ClearContents
[h6:k6].Validation.Delete
a = mad.Item([g6].Value).keys
[h6].Validation.Add Type:=xlValidateList, Formula1:=Join(a, ",")
Case "H6": filldict
[I6:k6].ClearContents
[I6:k6].Validation.Delete
a = mdd.Item([g6].Value & "|" & [h6].Value).keys
[i6].Validation.Add Type:=xlValidateList, Formula1:=Join(a, ",")
Case "I6": filldict
[J6:k6].ClearContents
[J6:k6].Validation.Delete
a = dvd.Item([g6].Value & "|" & [h6].Value & "|" & [i6].Value).keys
[j6].Validation.Add Type:=xlValidateList, Formula1:=Join(a, ",")
Case "J6": filldict
[k6].ClearContents
[k6].Validation.Delete
a = kmd.Item([g6].Value & "|" & [h6].Value & "|" & [i6].Value & "|" & [j6].Value).keys
If UBound(a) = 0 Then [k6] = a(0) Else [k6].Validation.Add Type:=xlValidateList, Formula1:=Join(a, ",")
End Select
err_:
Application.EnableEvents = True
End Sub
Sub filldict()
Dim i&, t$
Set mad = CreateObject("Scripting.Dictionary")
Set mdd = CreateObject("Scripting.Dictionary")
Set dvd = CreateObject("Scripting.Dictionary")
Set kmd = CreateObject("Scripting.Dictionary")
a = [a3:e18].Value
For i = 1 To UBound(a)
t = a(i, 1)
If Not mad.exists(t) Then mad.Add t, CreateObject("Scripting.Dictionary")
mad.Item(t).Item(a(i, 2)) = 0&
t = a(i, 1) & "|" & a(i, 2)
If Not mdd.exists(t) Then mdd.Add t, CreateObject("Scripting.Dictionary")
mdd.Item(t).Item(a(i, 3)) = 0&
t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3)
If Not dvd.exists(t) Then dvd.Add t, CreateObject("Scripting.Dictionary")
dvd.Item(t).Item(a(i, 4)) = 0&
t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
If Not kmd.exists(t) Then kmd.Add t, CreateObject("Scripting.Dictionary")
kmd.Item(t).Item(a(i, 5)) = 0&
Next
[g6].Validation.Delete
[g6].Validation.Add Type:=xlValidateList, Formula1:=Join(mad.keys, ",")
End Sub
даже осмыслить страшновато)
просто не понятны еще такие конструкции - понять не могу как формируются, материала Очень много но пока до него не совсем дорос, только блуждаю по мелководью да присматриваюсь. мне бы примеры- чем проще и тупее (совсем для новичков) с описанием - может и сам чего то да сподобился........когда мастодонты описывают макросы с использованием нескольких словарей в сложных макросах у меня честно глаза выползают из орбит и мозг лопается...... если не трудно поясните немного механизм формирования и работы со словарями на простых примерах (на Любых- чем проще тем лучше) пока въехать не могу......
Tesla_LOLa, здравствуйте! Попробую себя в роли учителя…
Задача разбивается на две подзадачи: получение списка "разрешённых" листов и удаление "неразрешённых" листов. В таком случае, возможно, имеете смысл обойтись без первого шага с формированием списка и сразу перейти к удалению листов в цикле по критерию (тому же, который бы служил для создания списка "разрешённых").
Что я имею ввиду: допустим, вам нужно ОСТАВИТЬ только те листы, название которых начинается на "ОСТАВИТЬ_". Вместо того, чтобы формировать список по этому критерию, можно сразу устроить цикл с проверкой по критерию.
НО В данном случае никаких догадок я делать не буду и рассматриваем "как есть", поэтому вот вам 2 макроса (простой и сложный) с комментариями:
КОД
Код
Option Explicit
'===============================================================================================================================================================
Sub DelSheets_HARD()
Dim sh As Worksheet, arr(), x, temp, lr&, i&, delim$, strCompare$
delim = "%%%" ' прописываем разделитель. Нужен для корректного поиска. Может быть другим, но не должен встречаться в искомом тексте
lr = Worksheets("0").Cells(Rows.Count, 7).End(xlUp).Row ' определяем последнюю заполненную строку 7 столбца на листе "0". Метод "прыжка".
If lr = 1 Then ' если последняя ячейка в 1 строке…
If Len(Worksheets("0").Cells(1, 7).Value) = 0 Then ' если ячейка пуста (количество символов содержимого = 0)…
MsgBox "Список разрешённых листов не найден!", vbCritical, "ОШИБКА АЛГОРИТМА"
Exit Sub
Else
strCompare = delim & Worksheets("0").Cells(1, 7).Value & delim ' если разрешён только 1 лист, то, чтобы не ломать алгоритм, всё равно создаём строку для сравнения
End If
Else
temp = Worksheets("0").Cells(1, 7).Resize(lr, 1).Value ' если дошли до сюда, то разрешённых листов больше одного, а значит забираем весь диапазон в массив
ReDim arr(0 To UBound(temp, 1)) ' объявляем новый массив
i = -1
For Each x In temp
i = i + 1
arr(i) = x ' наполняем новый массив в цикле
Next x
strCompare = delim & Join(arr, delim) & delim ' все эти манипуляции с массивами нужны только для того, чтобы получить строку для сравнения (все имена "разрешённых" листов, сцепленные через разделитель + разделители по краям строки слева и справа)
End If
MsgBox strCompare 'вывод строки, чтобы вы её увидели (удалить эту строку кода после ознакомления)
Application.DisplayAlerts = 0 ' отключаем предупреждения об удалении листа
For Each sh In ActiveWorkbook.Worksheets ' главный цикл (по листам книги). Сравниваем, содержится ли имя текущего проверяемого листа в цикле в списке разрешённых (строка сравнения). Строка сравнения позволяет избежать двойного цикла.
If InStr(1, strCompare, delim & sh.Name & delim) = 0 Then
sh.Delete
End If
Next sh
Application.DisplayAlerts = 1 ' включаем предупреждения об удалении листа обратно
End Sub
'===============================================================================================================================================================
Sub DelSheets_EASY()
Dim sh As Worksheet, rng As Range, cl As Range, lr&, flag As Boolean
lr = Worksheets("0").Cells(Rows.Count, 7).End(xlUp).Row
Set rng = Worksheets("0").Cells(1, 7).Resize(lr, 1) 'запоминаем диапазон "разрешённых" листов
Application.DisplayAlerts = 0
For Each sh In ActiveWorkbook.Worksheets
For Each cl In rng.Cells
If CStr(cl.Value) = sh.Name Then flag = True ' если значение ячейки=имени листа, то ставим флаг, что этот лист - разрешённый и его удалять не надо
Next cl
If flag = False Then sh.Delete ' если флаг не выставлен, то удаляем
flag = False 'скидываем флаг
Next sh
Application.DisplayAlerts = 1
End Sub
'===============================================================================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Вариант с коллекцией (хотя как по мне так словари удобней)
Скрытый текст
Код
Sub iSheetsDel()
' ------------------------
Dim sht As Worksheet
Dim arr(), ikey, lrow&
Dim coll As Collection
' ------------------------
Application.DisplayAlerts = False
Set coll = New Collection
Set sht = Worksheets("sheet1")
With sht
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.[a7], .Cells(lrow, 1)).Value
End With
On Error Resume Next
For Each ikey In arr
coll.Add ikey, CStr(ikey)
Next ikey
For Each sht In Worksheets
coll.Add sht.Name, CStr(sht.Name)
If Err.Number <> 0 Then sht.Delete: Err.Clear
Next sht
On Error GoTo 0
Application.DisplayAlerts = True
End Sub
Sub DelSheets()
Dim sh As Object
Application.DisplayAlerts = False
For Each sh In Sheets
If IsError(Application.Match(sh.Name, Worksheets("check").Columns(7), 0)) Then sh.Delete
Next
Application.DisplayAlerts = True
End Sub
Sub ShDel()
Dim AL As Object, sh As Worksheet, aa As Range
Set AL = CreateObject("System.Collections.ArrayList")
For Each aa In Intersect(ActiveSheet.UsedRange, Columns(1))
If Not AL.Contains(aa.Value) Then AL.Add aa.Value
Next
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Worksheets
If Not AL.Contains(sh.Name) Then sh.Delete
Next
Application.DisplayAlerts = True: Set AL = Nothing
End Sub
Sub ShGen()
Dim sh As Worksheet, a&
For a = 1 To Worksheets.Count
Cells(a, 1) = Sheets(a).Name
Next
For a = 1 To 5
Set sh = Worksheets.Add(, Worksheets(Sheets.Count))
Next
Sheets(1).Activate
End Sub
Sub SheetsDel()
Dim sh As Worksheet
Dim lrow&, arr(), ikey
Set sh = Worksheets("Имя листа со списком")
With sh
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.[a7], .Cells(lrow, 1)).Value
End With
Application.DisplayAlerts = False
On Error Resume Next
For Each ikey In arr
Set sh = Worksheets(ikey)
If Not sh Is Nothing Then sh.Delete
Next
Application.DisplayAlerts = True
End Sub
"Все гениальное просто, а все простое гениально!!!"
Sub TEST()
With Application: .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlManual: End With
a = ThisWorkbook.Sheets("Лист1").Range("A1").CurrentRegion.Value
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1 ' если в массиве только числа, то можно без этой строки
For i = 1 To UBound(a, 1)
dic.Add a(i, 1), 0&
Next i
With dic
For Each sh In ThisWorkbook.Sheets
If Not .exists(CStr(sh.Name)) Then
Debug.Print sh.Name
sh.Delete
End If
Next sh
End With
With Application: .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlAutomatic: End With
End Sub
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
повторюсь: поиск на форуме работает - не стесняйтесь ему формулировать свои хотелки... и адаптировать ответы под свои нюансы... "Чтобы запрограммировать что-либо - надо знать логическую последовательность шагов, которую хотите закодировать!!"... а чтобы её выразить на языке (это уже др. задача) - воспользуйтесь документацией по синтаксису языка (любая справка)... все программисты так учатся при появлении каждого нового языка... -- не обязательно знать язык, чтобы начать писать код... - знайте Что хотите писать, и подсматривайте синтаксис в справке(поиске/форуме) по языку... опыт нарабатывается практикой!
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Sub DelSheets()
Dim ws As Worksheet: Application.DisplayAlerts = False
For Each ws In Sheets
If Sheets("check").Columns(7).Find(ws.Name, LookAt:=xlWhole) Is Nothing Then ws.Delete
Next
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄