Изменение типа шрифта в динамических диапазонах на нескольких листах

Question

Я пытаюсь создать цикл для изменения типа шрифта и цвета шрифта на основе текста в ячейках в 3 листах, каждый с именованным динамическим диапазоном.Я не могу выбрать все ячейки на листах, потому что у меня есть легенда в ячейках выше диапазона.

Я успешно отформатировал каждый диапазон отдельно, но мне было интересно, есть ли более эффективный способ.Я понимаю, что Range не будет работать на нескольких листах.Я пытался использовать Collection и Array с именованными диапазонами.Я явно не понимаю, как их использовать, потому что ни один не работал.

Я пытался выяснить это в течение недели.Я прочитал очень много постов, но большинство из них пытаются выполнить функцию в определенном диапазоне на листах.Я очень плохо знаком с VBA (все кодирование), и это самое близкое, что я пришел.

Это то, что сработало.

Sub Macro3()

Dim daily As Worksheet, mon As Worksheet, per As Worksheet
Dim ws As Worksheet, cell As Range
Dim d1 As Range, m1 As Range, p1 As Range

Set daily = Sheets("Daily")
Set mon = Sheets("Monthly")
Set per = Sheets("Personnel")
Set d1 = daily.Range(("A7"), daily.Range("A7").End(xlUp) _
   .Offset(-1, 46))
Set m1 = mon.Range("A6:Y6")
Set p1 = per.Range(("A4"), per.Range("A4").End(xlUp).Offset(1, 20))

With d1
    Cells.Replace What:="", Replacement:="T"
    Cells.Replace What:="Incomplete", Replacement:="T"
    Cells.Replace What:="Complete", Replacement:="R"
    Cells.Replace What:="Not Applicable", Replacement:="x"
End With

d1.HorizontalAlignment = xlCenter

For Each cell In d1
    If cell.Value = "T" Then
        cell.Font.Name = "Wingdings 2"
    ElseIf cell.Value = "R" Then
        cell.Font.Name = "Wingdings 2"
    ElseIf cell.Value = "x" Then
        cell.Font.Name = "Webdings"
    ElseIf cell.Value = "v" Then
        cell.Font.Name = "Wingdings"
    End If
Next

With d1
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With

' this is repeated for m1 and then p1
End Sub

Это не

Set dta_all = Array(Sheets("Daily").daily.Range(("A7"), _ 
        daily.Range("A7").End(xlUp).Offset(-1, 46)), _
        Sheets("Monthly").Range("A6:Y6"), _
       Sheets("Personnel").Range(("A4"), _
        per.Range("A4").End(xlUp).Offset(1, 20)))

For Each ws In ThisWorkbook.Worksheets
    For Each cell In dta_all
        If cell.Text = "Incomplete" Then
            cell.Value = "T"
            cell.Font.Name = "Wingdings 2"
            cell.Font.Bold = True
            cell.Font.Color = vbRed
        End If
    Next
Next

Я получаю сообщение об ошибке 438 - свойство или метод не поддерживаются.Буду очень признателен за вашу помощь.

Answer 1

Вы можете создать массив диапазонов (я никогда раньше не пробовал, но, кажется, это отличный вариант для запоминания). Повторно используя ваш код, а также, как предложил Тим, я сделал пример, как это сделать, см. Ниже:

Option Explicit
Sub Macro3()

Dim wb As Workbook: Set wb = ActiveWorkbook
Dim daily As Worksheet, mon As Worksheet, per As Worksheet

Set daily = wb.Sheets("Daily")
Set mon = wb.Sheets("Monthly")
Set per = wb.Sheets("Personnel")

'Take the ranges into an array of ranges
Dim arrRanges(1 To 3) As Range   'add more as needed

'Set each element of the array as you would have with normal variables
Set arrRanges(1) = daily.Range(("A7"), daily.Range("A7").End(xlUp).Offset(-1, 46)) 'd1
Set arrRanges(2) = mon.Range("A6:Y6") 'm1
Set arrRanges(3) = per.Range(("A4"), per.Range("A4").End(xlUp).Offset(1, 20)) 'p1

Dim R As Long, C As Long, X As Long

'Now you can loop through
    For X = LBound(arrRanges) To UBound(arrRanges)  'For each of the ranges
        For R = 2 To arrRanges(X).Rows.Count    'For each row in each range - except headers
            For C = 1 To arrRanges(X).Columns.Count 'For each column in each range
                'Debug.Print arrRanges(X).Cells(R, C).Address 'for debuging purposes
                With arrRanges(X)
                    .Cells(R, C).Value = setReplacements(.Cells(R, C).Value)
                    Call setFont(.Cells(R, C))
                End With
            Next C
        Next R

        With arrRanges(X).Offset(1, 0)
            .Resize(.Rows.Count - 1).HorizontalAlignment = xlCenter 'align everything except headers
            Call setBorders(.Resize(.Rows.Count - 1)) 'set borders to everything except headers
        End With
    Next X

End Sub

Function setReplacements(str As String)
'Set the replacements here
    Select Case str
        Case "", "Incomplete"
            setReplacements = "T"
        Case "Complete"
            setReplacements = "R"
        Case "Not Applicable"
            setReplacements = "x"
        Case Else
            'do something here
            setReplacements = "T" 'assume incomplete for any other value?
    End Select
End Function

Sub setFont(rng As Range)
'Set your other formatting here
    Select Case rng.Value
        Case "T", "R"
            rng.Font.Name = "Wingdings 2"
        Case "x"
            rng.Font.Name = "Webdings"
        Case "v"
            rng.Font.Name = "Wingdings"
    End Select
End Sub

Sub setBorders(rng As Range)
'Set your borders here
    With rng
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeRight).Weight = xlMedium
    End With
End Sub

Одна вещь, которую нужно иметь в виду ... циклическая обработка листа никогда не будет хорошей идеей, особенно если у вас большое количество строк. К сожалению, когда дело доходит до форматирования, это не так много, вы можете сделать, но это. Однако для общих данных лучше всего загружать ваши данные в массив, выполнять преобразования, а затем выплевывать их ... чем меньше вы взаимодействуете с листами, тем быстрее они выполняются.

Answer 2

Если вы посмотрите на общие / повторяющиеся части вашего кода:

With d1
    .Cells.Replace What:="", Replacement:="T"
    'etc
End With

d1.HorizontalAlignment = xlCenter

For Each cell In d1
   'etc
Next

With d1
    .Borders(xlInsideVertical).Weight = xlThin
    'etc
End With

Что вы можете сделать, это создать отдельную подпрограмму, содержащую только те части, которая принимает Range в качестве аргумента:

Sub ApplyFormat(rng As Range)
    With rng
        .Cells.Replace What:="", Replacement:="T"
        'etc
    End With

    rng.HorizontalAlignment = xlCenter

    For Each cell In rng.Cells
       'etc
    Next

    With rng
        .Borders(xlInsideVertical).Weight = xlThin
        'etc
    End With
End sub

... и затем позвоните if из основного кода:

ApplyFormat d1
ApplyFormat m1
ApplyFormat p1

Всякий раз, когда вы пишете один и тот же набор строк более одного раза, это может быть хорошим кандидатом для факторингав отдельную подпункт: идентифицируйте переменную часть (и) и задайте их параметры в подпункте или функции.