Есть два макроса, которые последовательно (вручную) запускаются в одной книге.
macros1 - общая и основная настройка листа macros2 - удаление и назначение именованных диапозонов и выпадающих списков
Если запустить macros2 - всё ОК. Если запустить macros1 и потом macros2, то macros2 не вносит изменений.
Нашёл часть кода, после которой запуск macros2 не даёт результата. Удаление Shapes на листе. По факту удаляются только Shapes Линии.
Код
Dim MyShape As Shape
For Each MyShape In ActiveWorkbook.Worksheets("ppr").Shapes
MyShape.Delete
Next
Почему этот код не позволяет работать этому коду:
Скрытый текст
Код
Sub NamesDropsX()
' clear all Names Удаление ВСЕХ именованных диапозонов
For Each IName In ActiveWorkbook.Names
IName.Delete ' delete ALL named areas !!!
Next
' set Print Area Устанока Области Печати
ActiveSheet.PageSetup.PrintArea = "$A$2:$AD$55"
' add "agents" and "pay" - заполнение диапозонов данными
Sheets("izsniedzeji").Select
Range("A1").Select
ActiveCell.FormulaR1C1 = "RK"
Range("A2").Select
ActiveCell.FormulaR1C1 = "VM"
Range("A3").Select
ActiveCell.FormulaR1C1 = "JP"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Parskait" ' unicode
Range("B2").Select
ActiveCell.FormulaR1C1 = "Skaidra nauda" ' unicode
Range("B3").Select
ActiveCell.FormulaR1C1 = "Karte" ' unicode
' set Names - pay | agent - Назначение именованных диапозонов
Sheets("izsniedzeji").Select
Range("A1:A3").Select
ActiveWorkbook.Names.Add Name:="agent", RefersToR1C1:="=izsniedzeji!R1C1:R3C1"
Range("B1:B3").Select
ActiveWorkbook.Names.Add Name:="pay", RefersToR1C1:="=izsniedzeji!R1C2:R3C2"
' clear All Drops - удаление всех выпадающих списков
Sheets("PPR").Select
ActiveCell.SpecialCells(xlCellTypeAllValidation).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Range("A18").Select
' set Drop - pay and agent = methode nr.2 - назначение ячеек с выпадающими списками
Sheets("PPR").Select
Range("J17:O17").Select ' pay name
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=pay"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "ERROR"
.InputMessage = ""
.ErrorMessage = "ERROR!!!"
.ShowInput = False
.ShowError = True
End With
Range("G46:P46").Select ' agent name
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=agent"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "ERROR"
.InputMessage = ""
.ErrorMessage = "ERROR!!!"
.ShowInput = False
.ShowError = True
End With
Range("A1").Select
End Sub
К множеству иных файлов уже был применён макрос1, а значит во всех этих файлах НЕВОЗМОЖНО применить макрос2!!! Как сделать эти "испорченные" файлы/книги редактируемыми макросом2 снова???
jack_21 написал: Нашёл часть кода, после которой запуск macros2 не даёт результата
Как Вы решили, что именно эта часть кода первого макроса влияет на работу второго? Покажите весь код первого макроса, а лучше файл-пример приложите (в формате Excel)
Согласие есть продукт при полном непротивлении сторон
Выполнением кода по этапам и запуском macros2 после каждого этапа. в зелёных ячейках на листе PPR должен назначатся выпадающий список макросом m2.NamesDropsX
К множеству иных файлов уже был применён макрос1, а значит во всех этих файлах НЕВОЗМОЖНО применить макрос2!!! Как сделать эти "испорченные" файлы/книги редактируемыми макросом2 снова???
jack_21 написал: По факту удаляются только Shapes Линии
Нет. По факту удаляются ВСЕ шейпы, в т.ч. и треугольники выпадающих списков. Эту часть кода лучше записать так (именно только для линий)
Код
'DELETEshapesADDlines ------------------------------------------------------------------------------------------
Dim MyShape As Shape
For Each MyShape In ActiveWorkbook.Worksheets("ppr").Shapes
If MyShape.Type = msoLine Then MyShape.Delete
Next
А вот как восстановить эти треугольники надо подумать. Сама проверка данных там есть
Согласие есть продукт при полном непротивлении сторон
Sanja написал: сохранил файл в новом формате (.xlsm) - закрыл - открыл - стрелочки появились
Ну да такое работает. Правда я сохранил в *.xlsx.
Проблема в том, что это коснулось 100..200 файлов. Пересохранять их всех (пусть и перебором в папке) изменит дату модификации файла. А этот вопрос я так и не решил ещё. Не изменять дату модификации файла
БМВ написал: Так решите, или то, что последний пост рекомендовал не работает?
Ooops! Видимо, пропустил... Буду терзать.
Цитата
Sanja написал: В Ваших кодах очень много макрорекордного мусора. Прочтите эту статью .
Это оттого, что это всё собрано в интернете от разных создателей (что-то исправлял, что-то нет), что-то записано мной. Спасибо, попробую и эту прочитать... На фоне того, что не могу найти понятный оптимизатор/чистильщик кода...
Sub XLStoXLS() ' XLS Макрос
On Error Resume Next: Err.Clear
' макрос работает только в Excel 2007 (и более новых версиях)
If Val(Application.Version) < 12 Then Exit Sub
' получаем полный путь к текущему файлу Excel
oldName$ = ActiveWorkbook.FullName
' выход, если файл уже в нужном формате (XLSB)
If UCase$(oldName$) Like "*.XLSB" Then Exit Sub
' формируем новое имя файла (меняем расширение)
newName$ = Left(oldName$, InStrRev(oldName$, ".")) & "xlsb"
' сохраняем файл под новым именем в формате XLSB
ActiveWorkbook.SaveAs newName$, xlExcel12
' удаляем прежний файл (в старом формате)
If Err = 0 Then Kill oldName$
'MsgBox "1st step = Saved as XLSB."
On Error Resume Next: Err.Clear
' макрос работает только в Excel 2007 (и более новых версиях)
If Val(Application.Version) < 12 Then Exit Sub
' получаем полный путь к текущему файлу Excel
oldName$ = ActiveWorkbook.FullName
' выход, если файл уже в нужном формате (XLSB)
If UCase$(oldName$) Like "*.XLS" Then Exit Sub
' формируем новое имя файла (меняем расширение)
newName$ = Left(oldName$, InStrRev(oldName$, ".")) & "xls"
' сохраняем файл под новым именем в формате XLS
ActiveWorkbook.SaveAs newName$, xlExcel8
' удаляем прежний файл (в старом формате)
If Err = 0 Then Kill oldName$
'MsgBox "Saved to XLSB and XLS"
End Sub