Sub Combine()
'UpdatebyExtendoffice20180205
    Dim I As Long
    Dim xRg As Range
    On Error Resume Next
    Worksheets.Add Sheets(1)
    ActiveSheet.Name = "Combined"
   For I = 2 To Sheets.Count
        Set xRg = Sheets(1).UsedRange
        If I > 2 Then
            Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
        End If
        Sheets(I).Activate
        ActiveSheet.UsedRange.Copy xRg
    Next
End Sub

Sub CopyFilledRows()    On Error Resume Next
    r = 1
    With Sheets(2)
        For Each c In Intersect(Selection, ActiveSheet.UsedRange).Cells
            If c <> "" Then
                .Cells(r, 1) = c
                r = r + 1
            End If
        Next
    End With
End Sub

=СЧЁТЕСЛИ(A:A;A2)>1

=СЧЁТЕСЛИ(D:D;D2)>1

Sub FillB2s()
  Dim ws As Worksheet
  For Each ws In Worksheets
    If ws.[b2] <> 1 Then ws.[b2].Interior.Color = 255
  Next
End Sub

Option Explicit'Автор Б. Виталий В. (bedvit)
'Макрос записан: 21/10/2016
'Редакция: 6 от 26/02/2020
'Действие: выделение разными цветами дубликатов в выделенных диапазонах
Sub select_replica() 'рабочий
Dim R As Range, Rf As Range, Rc As Range, i As Long, s(3) As Long, ac, t, x, cell
Dim Dict: Set Dict = CreateObject("Scripting.Dictionary")
Dim DictColor: Set DictColor = CreateObject("Scripting.Dictionary")
t = Timer
 
On Error Resume Next
If Selection.CountLarge = 1 Then
    Set Rf = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
    Set Rc = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, 23)
Else
    Set Rf = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeFormulas, 23)
    Set Rc = Intersect(ActiveSheet.UsedRange, Selection).SpecialCells(xlCellTypeConstants, 23)
End If
On Error GoTo 0
 
With Application: .ScreenUpdating = 0: .DisplayAlerts = 0: .EnableEvents = 0: ac = .Calculation: .Calculation = -4135: .StatusBar = "BE: обработка данных...": End With
Set R = Rf: GoSub Go_
Set R = Rc: GoSub Go_
With Application: .ScreenUpdating = 1: .DisplayAlerts = 1: .EnableEvents = 1: .Calculation = ac: .StatusBar = False: End With
Debug.Print "select_replica = " & Timer - t
MsgBox "Выделено разных групп дубликатов (разными цветами): " & i, vbInformation
Exit Sub
     
Go_:
If Not R Is Nothing Then
    R.Interior.Pattern = Empty
    For Each cell In R.Cells
        If Dict.Exists(cell.Value) Then
            x = Dict.Item(cell.Value)
            If x(3) = 1 Then
                i = i + 1
                x(2) = 6740479
            cell.Interior.Color = x(2)
        Else
            s(0) = cell.Row
            s(1) = cell.Column
            s(3) = 1
            Dict.Add cell.Value, s
        End If
    Next
End If
Return
End Sub
 
Function Generate_nice_color() As Long
Dim R As Long, G As Long, B As Long
Do
    Randomize
    R = Int(Rnd * 256)
    G = Int(Rnd * 256)
    B = Int(Rnd * 256)
Loop Until R + G + B > 500 And R + G + B < 700
Generate_nice_color = RGB(R, G, B)
End Function

=ЕСЛИМН(ДЛСТР(M2)>0;K2<=M2;ДЛСТР(O2)>0;K2<=O2;ДЛСТР(Q2)>0;K2<=Q2;ДЛСТР(S2)>0;K2<=S2;ДЛСТР(U2)>0;K2<=U2;ДЛСТР(W2)>0;K2<=W2;ДЛСТР(Y2)>0;K2<=Y2;ДЛСТР(AA2)>0;K2<=AA2;ДЛСТР(AC2)>0;K2<=AC2;ДЛСТР(AE2)>0;K2<=AE2;ДЛСТР(AG2)>0;K2<=AG2;ДЛСТР(AI2)>0;K2<=AI2;ДЛСТР(AK2)>0;K2<=AK2;ДЛСТР(AM2)>0;K2<=AM2;ДЛСТР(AO2)>0;K2<=AO2;ДЛСТР(AQ2)>0;K2<=AQ2;ДЛСТР(AS2)>0;K2<=AS2)

 =ЕСЛИ(ИЛИ(ДЛСТР(M2)>0;ДЛСТР(O2)>0;ДЛСТР(Q2)>0;ДЛСТР(S2)>0;ДЛСТР(U2)>0;ДЛСТР(W2)>0;ДЛСТР(Y2)>0;ДЛСТР(AA2)>0;ДЛСТР(AC2)>0;ДЛСТР(AE2)>0;ДЛСТР(AG2)>0;ДЛСТР(AI2)>0;ДЛСТР(AK2)>0;ДЛСТР(AM2)>0;ДЛСТР(AO2)>0;ДЛСТР(AQ2)>0;ДЛСТР(AS2)>0);И(K2<=M2;K2<=O2;K2<=Q2;K2<=S2;K2<=U2;K2<=W2;K2<=Y2;K2<=AA2;K2<=AC2;K2<=AE2;K2<=AG2;K2<=AI2;K2<=AK2;K2<=AM2;K2<=AO2;K2<=AQ2;K2<=AS2))

Set rg = Intersect([g:i], ActiveSheet.UsedRange)

 Set rg = Intersect([g:j], ActiveSheet.UsedRange)