Обновление диапазона ячеек, основанных на значении другой ячейки

Question

Я чрезвычайно новичок, поэтому, пожалуйста, несите меня. Я хочу оценить каждую ячейку в диапазоне C5: BM5. Если какая-либо из ячеек в этом диапазоне = «HOLIDAY» или «SUN», мне нужно, чтобы в этом столбце были строки 7-19. Я собрал код ниже, который делает то, что мне нужно, он просто делает это очень медленно. Я знаю, что должен быть лучший способ. Ищите какой-то умный совет.

Sub HolidayUpdate() 

Dim Cell As Range 

For Each Cell In Sheets("Production Calendar").Range("C5:BM5") 

If Cell = "HOLIDAY" Then 
Cell.Offset(2, 0).ClearContents 
Cell.Offset(3, 0).ClearContents 
Cell.Offset(4, 0).ClearContents 
Cell.Offset(5, 0).ClearContents 
Cell.Offset(6, 0).ClearContents 
Cell.Offset(7, 0).ClearContents 
Cell.Offset(8, 0).ClearContents 
Cell.Offset(9, 0).ClearContents 
Cell.Offset(10, 0).ClearContents 
Cell.Offset(11, 0).ClearContents 
Cell.Offset(12, 0).ClearContents 
Cell.Offset(13, 0).ClearContents 
Cell.Offset(14, 0).ClearContents 
ElseIf Cell = "SUN" Then 
Cell.Offset(2, 0).ClearContents 
Cell.Offset(3, 0).ClearContents 
Cell.Offset(4, 0).ClearContents 
Cell.Offset(5, 0).ClearContents 
Cell.Offset(6, 0).ClearContents 
Cell.Offset(7, 0).ClearContents 
Cell.Offset(8, 0).ClearContents 
Cell.Offset(9, 0).ClearContents 
Cell.Offset(10, 0).ClearContents 
Cell.Offset(11, 0).ClearContents 
Cell.Offset(12, 0).ClearContents 
Cell.Offset(13, 0).ClearContents 
Cell.Offset(14, 0).ClearContents 
End If 

Next Cell 

End Sub 

Answer 1

1. вы можете объединить все ваши коррекции.
2. вы можете отключить расчет и обновление экрана.

3. Это обновление для вашего кода.

   Sub HolidayUpdate() 
   
   Dim rgCell As Range 
   
   application.screenupdating=false 
   application.calculation=xlcalculationmanual 
   
   For Each rgCell In Sheets("Production Calendar").Range("C5:BM5") 
   
       If rgCell = "HOLIDAY" OR rgCell = "SUN" _ 
        Then rgCell.Offset(2, 0).resize(13).ClearContents 
   
   Next rgCell 
   
   application.screenupdating=true 
   application.calculation=xlCalculationAutomatic 
   
   End Sub