Окрашивание ячеек, которые зависят от других ячеек - PullRequest
0 голосов
/ 30 октября 2019

Я сделал код, который проверяет, было ли указано значение ячейки на каком-либо другом листе. Просто он проверяет зависимость клеток и окрашивает ее. По сути, я перешел к зависимости ячейки, и если имя листа не совпадает с тем, каким оно было вначале, оно окрашивает его. Вот код

Dim r As Long, c As Long, sh As Worksheet, name As String, rg As Range, chksh As String ' r is row and c is coloumn
Application.ScreenUpdating = False
Application.EnableEvents = False

name = "Main sheet"

Set sh = ThisWorkbook.Sheets(name)
Set rg = sh.Range("A4").CurrentRegion

r = rg.Rows.Count
c = rg.Columns.Count

Dim i As Long, j As Long
i = 1
j = 1
sh.Select

Do While i < r + 1
    j = 1
    Do While j < c + 1
        sh.Cells(i, j).Select
        Selection.ShowDependents
        ActiveCell.NavigateArrow TowardPrecedent:=False, ArrowNumber:=1, _
        LinkNumber:=1
        chksh = ActiveSheet.name
        If chksh <> name Then 'there is a dependent in other sheet

            sh.Select
            With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
             End With
        End If
        j = j + 1
    Loop
    i = i + 1
Loop

ActiveSheet.ClearArrows
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Это занимает слишком много времени из-за использования .select. Пожалуйста, предложите улучшенный код без использования select, чтобы он мог работать в мгновение ока.

1 Ответ

0 голосов
/ 30 октября 2019

Упрощенно:

Sub Tester()

    Dim sh As Worksheet, rg As Range, c As Range

    Set sh = ThisWorkbook.Sheets("Main sheet")

    Set rg = sh.Range("A4").CurrentRegion

    For Each c In rg.Cells
        c.ShowDependents
        c.NavigateArrow TowardPrecedent:=False, ArrowNumber:=1, LinkNumber:=1
        If ActiveSheet.name <> sh.name Then
            c.Interior.Color = vbRed
        End If
    Next c

    sh.ClearArrows

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...