Найти и заменить код в VBA

Question

Я новичок в stackoverflow и VBA, а также. Я пытаюсь написать код, который читает имя файла с одной вкладки листа, переходит на другую вкладку листа, ищет это имя файла. Если код находит имя файла из Sheet1 точно так же, как в Sheet2, он выделяет цвет этой ячейки в Sheet2. У меня есть частичный успех в этом. Вот проблемы:

На Листе 1 имена файлов похожи на ФАЙЛ 001, ФАЙЛ 028, ФАЙЛ 38, ФАЙЛ 102 и т. Д. Я вручную изменил некоторые имена файлов, чтобы они имели три цифры в своем номере (просто для проверки кода). Пока код достигает ФАЙЛА 38, он останавливается. Итак, вопрос1, как я могу сначала изменить все имена файлов, чтобы иметь 3 цифры в именах?

Во-вторых, на Листе 2 ФАЙЛ 001 появляется более одного раза. Мой код выделяет только первый найденный экземпляр. Как решить эту проблему? Я копирую приведенный ниже код и ценю помощь.

Sub ColorImportantFiles()

Dim NumberOfCells As Integer
Dim LoopCounter As Integer
Dim FileName As String
Dim SearchFileRange As Range

Worksheets("Sheet1").Activate
NumberOfCells = Range("A3:A38").Count

For LoopCounter = 1 To NumberOfCells
    Worksheets("Sheet1").Activate
    FileName = Range("A2").Offset(LoopCounter, 1).Value

    Worksheets("Sheet2").Activate
    Set SearchFileRange = Range("B3", Range("B2").End(xlDown))

       If SearchFileRange.Find(what:=FileName, lookat:=xlWhole) = FileName Then
       SearchFileRange.Find(what:=FileName, lookat:=xlWhole).Interior.Color 
   = rgbBlueViolet

       Else: Exit Sub
       End If
   Next LoopCounter
End Sub

Answer 1

Вы можете попробовать это:

Option Explicit

Sub ColorImportantFiles()

    Dim fileName As String, firstAddress As String
    Dim searchFileRange As Range, cell As Range, f As Range, cellsToColor As Range

    With Worksheets("Sheet2")
        Set searchFileRange = .Range("B3", .Range("B2").End(xlDown))
        Set cellsToColor = .Range("A1")
    End With

    For Each cell In Worksheets("Sheet1").Range("A3:A38").SpecialCells(xlCellTypeConstants)
        fileName = "FILE " & Format(Split(cell.Value, " ")(1), "000")
        With searchFileRange
            Set f = .Find(what:=fileName, LookIn:=xlValues, lookat:=xlWhole)
            If Not f Is Nothing Then
                firstAddress = f.Address
                Do
                    Set cellsToColor = Union(f, cellsToColor)
                    Set f = .FindNext(f)
                Loop While f.Address <> firstAddress
            End If
        End With
    Next
    If cellsToColor.Count > 1 Then Intersect(cellsToColor, cellsToColor.Parent.Columns(2)).Interior.Color = rgbBlueViolet

End Sub