Sub FonColor()[P]Dim Rg As Range
For Each Rg In Range("A4:CJ3000")
If Rg.Interior.ThemeColor = 15257016 Then
End If
Next
End Sub

Sub CombineWorkbooks()

Dim FilesToOpen
Dim x As Integer

Application.ScreenUpdating = False 'отключаем обновление экрана для скорости

'вызываем диалог выбора файлов для импорта
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="All files (*.*), *.*", _
MultiSelect:=True, Title:="Files to Merge")

If TypeName(FilesToOpen) = "Boolean" Then
           MsgBox "Не выбрано ни одного файла!"
           Exit Sub
End If

'проходим по всем выбранным файлам
x = 1

While x <= UBound(FilesToOpen)
Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))

Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

importWB.Close savechanges:=False
x = x + 1

Wend

Application.ScreenUpdating = True
End Sub

Sub Копирование_новых_заявок_с_перестановкой_столбцов()
    Dim sh1 As Worksheet: Set sh1 = Worksheets("выгрузка из базы")
    Dim sh2 As Worksheet: Set sh2 = Worksheets("Рабочий реестр")
      
    Dim y1 As Long
    Dim y2 As Long
    Dim x1 As Integer
    Dim x2 As Integer
      
    With sh1
        y1 = .Cells(.Rows.Count, 3).End(xlUp).Row
        x1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Dim a As Variant
        Dim b As Variant
        a = .Range(.Cells(1, 1), .Cells(y1, x1))
        ReDim b(1 To 1, 1 To x1)
    End With
      
    With sh2
        y2 = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
    End With
      
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For x1 = 1 To UBound(a, 2)
        If WorksheetFunction.CountIfs(sh2.Rows(1), a(1, x1)) > 0 Then
            dic(x1) = WorksheetFunction.Match(a(1, x1), sh2.Rows(1), 0)
        End If
    Next
      
    For y1 = 3 To UBound(a, 1)
        If a(y1, 3) <> "" Then
            If WorksheetFunction.CountIfs(sh2.Columns(3), a(y1, 3)) = 0 Then
                'sh1.Rows(y1).Copy sh2.Rows(y2)
                For x1 = 1 To UBound(a, 2)
                    If dic.Exists(x1) Then
                        x2 = dic(x1)
                    Else
                        x2 = UBound(a, 2)
                    End If
                    b(1, x2) = a(y1, x1)
                Next
                sh2.Cells(y2, 1).Resize(1, UBound(a, 2)) = b
                sh2.Rows(y2).Interior.Color = RGB(200, 255, 200)
                y2 = y2 + 1
            End If
        End If
    Next
End Sub