Проблема следующая, есть файл, порядка трехсот листов, на каждом листе есть формулы, правила условного форматирования, именованные диапазоны с формулами, и все это хозяйство жутко тормозит. Но из этих 300листов, с формулами нужны только штук 20 для текущего месяца, Можно ли сделать так, чтобы в листах из списка на листе "АРХИВАЦИЯ":
Все формулы преобразовать в значения, Все форматы оставить, как они были до выполнения макроса и удалить правила условного форматирования с листа С диспетчера имен удалить все именованные диапазоны, а имя Область Печати привязать к строгому текущему диапазону (область печати определяется формулами)
Спасибо за любую помощь!
[offtop]Я в теме макросов на уровне записать макрорекодером
Здравствуйте, Друзья
Проблема следующая, есть файл, порядка трехсот листов, на каждом листе есть формулы, правила условного форматирования, именованные диапазоны с формулами, и все это хозяйство жутко тормозит. Но из этих 300листов, с формулами нужны только штук 20 для текущего месяца, Можно ли сделать так, чтобы в листах из списка на листе "АРХИВАЦИЯ":
Все формулы преобразовать в значения, Все форматы оставить, как они были до выполнения макроса и удалить правила условного форматирования с листа С диспетчера имен удалить все именованные диапазоны, а имя Область Печати привязать к строгому текущему диапазону (область печати определяется формулами)
Спасибо за любую помощь!
[offtop]Я в теме макросов на уровне записать макрорекодеромRichman
Вот нашел макрос Alex_ST для выделенного диапазона. Теперь остается выделить листы из списка и внести их в макрос, если я правильно понимаю
[vba]
Код
Sub Replace_by_VAL() ' в выбранном диапазоне в не скрытых ячейках заменить формулы на значения Dim rRng As Range, rAr As Range On Error Resume Next With ActiveWindow.RangeSelection.Cells If .Count = 1 Or .MergeCells Then .Item(1) = .Item(1).Value: .Item(1).Font.Color = vbBlack: Exit Sub Else Set rRng = .SpecialCells(xlCellTypeFormulas).SpecialCells(xlCellTypeVisible) End If End With If rRng Is Nothing Then Exit Sub For Each rAr In rRng.Areas: rAr.Value = rAr.Value: Next rRng.Select rRng.Font.Color = vbBlack End Sub
Вот нашел макрос Alex_ST для выделенного диапазона. Теперь остается выделить листы из списка и внести их в макрос, если я правильно понимаю
[vba]
Код
Sub Replace_by_VAL() ' в выбранном диапазоне в не скрытых ячейках заменить формулы на значения Dim rRng As Range, rAr As Range On Error Resume Next With ActiveWindow.RangeSelection.Cells If .Count = 1 Or .MergeCells Then .Item(1) = .Item(1).Value: .Item(1).Font.Color = vbBlack: Exit Sub Else Set rRng = .SpecialCells(xlCellTypeFormulas).SpecialCells(xlCellTypeVisible) End If End With If rRng Is Nothing Then Exit Sub For Each rAr In rRng.Areas: rAr.Value = rAr.Value: Next rRng.Select rRng.Font.Color = vbBlack End Sub
RAN, Области печати задается именованным диапазоном, соответственно если удалить именованные диапазоны, то область печати будет отображаться не корректно. Вот картинка, думаю должно быть понятно.
Спасибо за внимание
RAN, Области печати задается именованным диапазоном, соответственно если удалить именованные диапазоны, то область печати будет отображаться не корректно. Вот картинка, думаю должно быть понятно.
Это я и в файле видел. А какой лист печатать? [p.s.]Как меня бесят подобные картинки. Ткнешь в нее, 10 минут что-то крутится, а в результате ничего, кроме какого-то г...[/p.s.]
Это я и в файле видел. А какой лист печатать? [p.s.]Как меня бесят подобные картинки. Ткнешь в нее, 10 минут что-то крутится, а в результате ничего, кроме какого-то г...[/p.s.]RAN
Sub Мяу() Dim arr, nm As Name, x, arrPrintArea, i& arr = Sheets("АРХИВАЦИЯ").Range(Sheets("АРХИВАЦИЯ").Cells(1, 1), Sheets("АРХИВАЦИЯ").Cells(Rows.Count, 1).End(xlUp)).Value If Not IsArray(arr) Then arr = Array(arr) On Error Resume Next ReDim arrPrintArea(LBound(arr) To UBound(arr), 1 To 2) i = LBound(arr) For Each x In arr If Len(x) Then With ThisWorkbook.Sheets(x) .UsedRange.Value = .UsedRange.Value .Cells.FormatConditions.Delete arrPrintArea(i, 1) = x arrPrintArea(i, 2) = .PageSetup.PrintArea i = i + 1 End With End If Next For Each nm In ThisWorkbook.Names nm.Delete Next For i = LBound(arrPrintArea) To UBound(arrPrintArea) ThisWorkbook.Sheets(arrPrintArea(i, 1)).PageSetup.PrintArea = arrPrintArea(i, 2) Next End Sub
[/vba]
[vba]
Код
Sub Мяу() Dim arr, nm As Name, x, arrPrintArea, i& arr = Sheets("АРХИВАЦИЯ").Range(Sheets("АРХИВАЦИЯ").Cells(1, 1), Sheets("АРХИВАЦИЯ").Cells(Rows.Count, 1).End(xlUp)).Value If Not IsArray(arr) Then arr = Array(arr) On Error Resume Next ReDim arrPrintArea(LBound(arr) To UBound(arr), 1 To 2) i = LBound(arr) For Each x In arr If Len(x) Then With ThisWorkbook.Sheets(x) .UsedRange.Value = .UsedRange.Value .Cells.FormatConditions.Delete arrPrintArea(i, 1) = x arrPrintArea(i, 2) = .PageSetup.PrintArea i = i + 1 End With End If Next For Each nm In ThisWorkbook.Names nm.Delete Next For i = LBound(arrPrintArea) To UBound(arrPrintArea) ThisWorkbook.Sheets(arrPrintArea(i, 1)).PageSetup.PrintArea = arrPrintArea(i, 2) Next End Sub