Страницы: 1
RSS
Последовательное выполнение макросов по последовательным листам
 
Добрый день.
Есть 4 макроса:
clean - очистка пустых строк
filter - применение фильтра
format - приведение в более менее читабельный формат
process - выполнение первых трех макросов
И есть около 20 листов. Как сделать выполнение через хитрый оператор n+1 для выбора листов последовательно и выполнения макросов?
Т.е. выбрали лист 1 - шлепнули 3 макроса, перешли ко 2му листу - снова 3 макроса и так до конца?
Код
Sub clean()
Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
    LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    Application.ScreenUpdating = False
    For r = LastRow To 1 Step -1
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
    Next r
End Sub
Sub filter()
    Range("A1:F1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$F$1000").AutoFilter Field:=1, Criteria1:=Array("5", _
        "¨ìêîñòü", "Çäîðîâüå", "Èìÿ Êîìïüþòåðà", "Ëîãè÷åñêèé Äèñê", "Ìîäåëü Ƹñòêîãî Äèñêà" _
        , "Íîìåð Ƹñòêîãî Äèñêà", "Ïðèáëèçèòåëüíî îñòàëîñü", "Ïðîèçâîäèòåëüíîñòü", _
        "Ñåðèéíûé Íîìåð Äèñêà"), Operator:=xlFilterValues
    Columns("A:A").ColumnWidth = 25
End Sub
Sub format() '
    Columns("B:B").ColumnWidth = 30
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:D").ColumnWidth = 7
    Columns("E:E").ColumnWidth = 5
    Cells.Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub
Sub process()
    Sheets("1").Select
     clean
     filter
     format
    Sheets("2").Select
     clean
     filter
     format
End Sub
 
maldini89, что-то вроде такого, наверное Вам подойдет:
Код
Sub iterateMacroOnGivenSheets()
    sheetsToProcess = Array("Лист1", "Лист2", "Лист3")
    
    For Each aSheet In sheetsToProcess
        ThisWorkbook.Sheets(aSheet).Activate
        clean
        filter
        format
    Next aSheet
    
End Sub

Изменено: tolstak - 11.10.2019 11:22:41
In GoTo we trust
 
tolstak, большое спасибо! Работает как часики ^^)
 
Цитата
maldini89: Работает как часики
ваши "часики" сильно надо починить  :D

1. В макрос отtolstak'а добавьте 5 строк
Код
Sub iterateMacroOnGivenSheets()
Dim AC&

Application.ScreenUpdating=False
AC = Application.Calculation
Application.Calculation=xlCalculationManual

    sheetsToProcess = Array("Лист1", "Лист2", "Лист3")
     
    For Each aSheet In sheetsToProcess
        ThisWorkbook.Sheets(aSheet).Activate
        clean
        filter
        format
    Next aSheet

Application.Calculation=AC
Application.ScreenUpdating=True
End Sub
2. В своих макросах избавьтесь от Select'ов: так например вместо
Код
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
гораздо лучше писать
Код
   For Each x in array(1,2,7) ' номера столбцов A, B и G
      Columns(x).Delete
   Next x
Rows(2).Delete
но тут надо понимать, что после удаления столбца/строк всё сдвигается. Именно поэтому обычно удаляют с конца, если циклом или собирают в группу и одним махом.

Мануал по оптимизации кода
Изменено: Jack Famous - 11.10.2019 12:18:36
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, благодарю за оптимизацию и напутствие, механизм работает уже лучше :)
Код
Sub clean() ' очистка ненужных и пустых строк
    For Each x In Array(1, 2, 3, 6) ' номера столбцов A, B, C и F
        Columns(x).Delete
    Next x
        Rows(2).Delete ' удалить 2 строку
    LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count 'определяем размеры таблицы
    Application.ScreenUpdating = False
    For r = LastRow To 1 Step -1           ' проходим от последней строки до первой
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete   ' если в строке пусто - удаляем ее
    Next r
End Sub
Sub filter() ' применение фильтра по столбцам
    Range("A1:F1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$F$1000").AutoFilter Field:=1, Criteria1:=Array("5", _
        "Ёмкость", "Здоровье", "Имя Компьютера", "Логический Диск", "Модель Жёсткого Диска" _
        , "Номер Жёсткого Диска", "Приблизительно осталось", "Производительность", _
        "Серийный Номер Диска"), Operator:=xlFilterValues
End Sub
Sub format() ' конечное форматирование
    Columns("A:A").ColumnWidth = 25
    Columns("B:B").ColumnWidth = 25
    Columns("C:C").ColumnWidth = 15
    Columns("D:D").ColumnWidth = 5
    Columns("E:E").ColumnWidth = 5
    Range("A:E").HorizontalAlignment = xlLeft
End Sub
Sub process_from_good_guys() ' последовательное выполнение макросов
    Dim AC&
    Application.ScreenUpdating = False
    AC = Application.Calculation
    Application.Calculation = xlCalculationManual
    sheetsToProcess = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21")
    For Each aSheet In sheetsToProcess
        ThisWorkbook.Sheets(aSheet).Activate
        clean
        filter
        format
    Next aSheet
    Application.Calculation = AC
    Application.ScreenUpdating = True
End Sub
 
maldini89,
Попробуйте вот так
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх