Перенести заливку строк из старой книги в новую

Код

Sub TransferColorsFromOldFile()
    Dim wbOld As Workbook, wbNew As Workbook
    Dim wsNew As Worksheet, wsOld As Worksheet
    Dim oldFilePath As Variant
    Dim sheetName As String
    Dim found As Range
    Dim processedRows As Object
    Dim i As Long, j As Long, lastRow As Long
    Dim colorValue As Long, searchValue As String

    Set wbNew = ThisWorkbook
    Set wsNew = wbNew.ActiveSheet
    sheetName = wsNew.Name

    oldFilePath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "Выберите СТАРУЮ книгу (с цветами)")
    If oldFilePath = False Then Exit Sub

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set wbOld = Workbooks.Open(oldFilePath)

    On Error Resume Next
    Set wsOld = wbOld.Sheets(sheetName)
    On Error GoTo 0
    Do While wsOld Is Nothing
        sheetName = InputBox("В старом файле нет листа '" & wsNew.Name & "'." & vbCrLf & _
                             "Введите имя листа:", "Имя листа")
        If Len(sheetName) = 0 Then GoTo CleanUp
        On Error Resume Next
        Set wsOld = wbOld.Sheets(sheetName)
        On Error GoTo 0
        If wsOld Is Nothing Then MsgBox "Лист не найден. Попробуйте снова.", vbExclamation
    Loop

    Set processedRows = CreateObject("Scripting.Dictionary")
    lastRow = wsOld.UsedRange.Rows.Count
    For i = 1 To lastRow
        For j = 1 To 70
            If wsOld.Cells(i, j).Interior.ColorIndex <> xlNone And _
               wsOld.Cells(i, j).Interior.ColorIndex <> -4142 And _
               wsOld.Cells(i, j).Interior.Color <> 16777215 Then
                If Not processedRows.Exists(i) Then
                    processedRows.Add i, i
                    searchValue = Trim$(CStr(wsOld.Cells(i, j).Value))
                    If Len(searchValue) > 0 Then
                        Set found = wsNew.Cells.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)
                        If Not found Is Nothing Then
                            wsNew.Rows(found.Row).Interior.Color = wsOld.Cells(i, j).Interior.Color
                        End If
                    End If
                End If
                Exit For
            End If
        Next j
    Next i

    If processedRows.Count > 0 Then
        wbNew.Save
        MsgBox "Обработано строк: " & processedRows.Count, vbInformation
    Else
        MsgBox "Цветных строк на листе не найдено.", vbExclamation
    End If

CleanUp:
    If Not wbOld Is Nothing Then wbOld.Close SaveChanges:=False
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Связанные члены API

Workbook.Close Range.Find Application.GetOpenFilename Application.ScreenUpdating