Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim myControlRange As Range
 Dim rng As Range, Stolbec As Range

 'назначаем конролируемую ячейку при изменении которой бдет запускаться макрос
 'и с этим занчением будут сравниваться данные
  Set myControlRange = Range("B3")

  'пропускаем ошибки
  On Error Resume Next

  If Selection.Cells.Count > 1 Then Exit Sub

   If Not Intersect(Target, myControlRange) Is Nothing Then

     'отключаем обновление и контроль событий
      Application.ScreenUpdating = False
      Application.EnableEvents = False

     'отображаем все столбцы, если были скрыты/со столбца F в данном случае
     Range(Cells(7, 6), Cells(7, Columns.Count)).EntireColumn.Hidden = False

     'устанавливаем диапазон данных где будем проверять данные/это строка 7 со столбца F
      Set Stolbec = Range(Cells(7, 6), Cells(7, Columns.Count).End(xlToLeft))

        'проверяем данные в каждой ячейке равенству для фильтра
          For Each rng In Stolbec
             If rng.Value <> Target.Value Then rng.EntireColumn.Hidden = True
          Next
   End If

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

=(ЕСЛИ(ИЛИ(E2='Служебная информация'!$I$4;E2='Служебная информация'!$I$6);
        (ВПР(E2;'Служебная информация'!I:J;2;ЛОЖЬ));(ВПР(D2;'Служебная информация'!B:C;2;ЛОЖЬ)*
        (ВПР(E2;'Служебная информация'!I:J;2;ЛОЖЬ)))))

Sub UniqArticul()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim ColArticul As Integer
Dim dict As Object
Dim arr
Dim Col As String

Col = Application.InputBox("Укажите название столбца", , , , , , , 2)

ThisWorkbook.Sheets.Add.Name = "Дубликаты"

   Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
  For Each Sht In Worksheets
    If Sht.Name <> "Дубликаты" Then
      With Sht
       Set FoundCell = .Rows(1).Find(Col, , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          ColArticul = FoundCell.Column
          iLastRow = .Cells(.Rows.Count, ColArticul).End(xlUp).Row
          arr = .Range(.Cells(2, ColArticul), .Cells(iLastRow, ColArticul))
          For i = 1 To UBound(arr)
            dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + Sht.Name & " строка: " & i + 1 & "; "
          Next
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
   Columns("C:D").ClearContents
   Range("C1").Resize(dict.Count, 2) = Application.Transpose(Array(dict.keys, dict.Items))
End Sub

...

Dim Col As Variant  ' Создаем переменную, которой присвоим значение - имя столбца (заголовок)
 
Set Col = Application.InputBox("Укажите название столбца", , , , , , , 2) ' Запрашиваем у пользователя имя столбца (заголовок) и заключаем его в переменную Col
 
ThisWorkbook.Sheets.Add.Name = "Дубликаты" ' Создаем лист для вывода
 
   Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
  For Each Sht In Worksheets
    If Sht.Name <> "Дубликаты" Then
      With Sht
       Set FoundCell = .Rows(1).Find(Col, , xlValues, xlWhole) 'Подставляем переменную вместо слова "Артикул"

...

Sub UniqArticul()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim ColArticul As Integer
Dim dict As Object
Dim arr

ThisWorkbook.Sheets.Add.Name = "Дубликаты"

    Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
  For Each Sht In Worksheets
    If Sht.Name <> "Дубликаты" Then
      With Sht
       Set FoundCell = .Rows(1).Find("Артикул", , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          ColArticul = FoundCell.Column
          iLastRow = .Cells(.Rows.Count, ColArticul).End(xlUp).Row
          arr = .Range(.Cells(2, ColArticul), .Cells(iLastRow, ColArticul))
          For i = 1 To UBound(arr)
            dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + Sht.Name & " строка: " & i + 1 & "; "
          Next
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
   Columns("C:D").ClearContents
   Range("C1").Resize(dict.Count, 2) = Application.Transpose(Array(dict.keys, dict.Items))
End Sub

Sub UniqArticul()
Dim Sht As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim ColArticul As Integer
Dim dict As Object
Dim arr
Dim Col As Variant

Set Col = Application.InputBox("Укажите название столбца", , , , , , , 2)

ThisWorkbook.Sheets.Add.Name = "Дубликаты"

   Set dict = CreateObject("Scripting.Dictionary"): dict.comparemode = 1
  For Each Sht In Worksheets
    If Sht.Name <> "Дубликаты" Then
      With Sht
       Set FoundCell = .Rows(1).Find("Col", , xlValues, xlWhole)
        If Not FoundCell Is Nothing Then
          ColArticul = FoundCell.Column
          iLastRow = .Cells(.Rows.Count, ColArticul).End(xlUp).Row
          arr = .Range(.Cells(2, ColArticul), .Cells(iLastRow, ColArticul))
          For i = 1 To UBound(arr)
            dict.Item(arr(i, 1)) = dict.Item(arr(i, 1)) + Sht.Name & " строка: " & i + 1 & "; "
          Next
        End If
        Set FoundCell = Nothing
      End With
    End If
  Next
   Columns("C:D").ClearContents
   Range("C1").Resize(dict.Count, 2) = Application.Transpose(Array(dict.keys, dict.Items))
End Sub

Sub FindDuplicates() 
         ' Declare ws as a worksheet object variable.
         Dim ws As Worksheet
 
Dim Dict As Object, aa As Range, arr()
Set Dict = CreateObject("Scripting.Dictionary")
          
         ' Loop through all of the worksheets in the active workbook.
         For Each ws In Worksheets
For Each aa In ws.Range("H2:I60000") ' <= 2. здесь был жестко прописан Sheets(1). , замененный на ws.
If aa <> "Сводная" Then
  If Len(aa.Value) > 0 Then
    If Not Dict.exists(aa.Value) Then
      Dict.Add aa.Value, 1
    Else
      Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
    End If
  End If
End If
Next
Next
 
On Error Resume Next
Set aa = Application.InputBox("Выберите ячейку для вывода результата", , , , , , , 8)
If aa <> "Сводная" Then
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys)  ' <= 1. здесь приводилась ошибка пустого словаря
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End If
 
End Sub

For Each aa In ws.Range("H2:I60000")

Sub FindDuplicates()
         ' Declare ws as a worksheet object variable.
         Dim ws As Worksheet
 
Dim Dict As Object, aa As Range, arr()
Dim myRange As Range

Set Dict = CreateObject("Scripting.Dictionary")
Set myRange = Application.InputBox("Выберите исследуемый диапазон", , , , , , , 8)          
         ' Loop through all of the worksheets in the active workbook.
         For Each ws In Worksheets
For Each aa In ws.Range(myRange) ' <= вот тут ошибка. Что я делаю не так?
If aa <> "Сводная" Then
  If Len(aa.Value) > 0 Then
    If Not Dict.exists(aa.Value) Then
      Dict.Add aa.Value, 1
    Else
      Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
    End If
  End If
End If
Next
Next
 
On Error Resume Next
Set aa = Application.InputBox("Выберите ячейку для вывода результата", , , , , , , 8)
If aa <> "Сводная" Then
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys)  ' <= 1. здесь приводилась ошибка пустого словаря
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End If
 
End Sub

Sub FindDuplicates()
Dim Dict As Object, aa As Range, arr()
Set Dict = CreateObject("Scripting.Dictionary")
For Each aa In Sheets(1).UsedRange
  If Len(aa.Value) > 0 Then
    If Not Dict.exists(aa.Value) Then
      Dict.Add aa.Value, 1
    Else
      Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
    End If
  End If
Next
On Error Resume Next
Set aa = Application.InputBox("Select distination cell.", , , , , , , 8)
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys)
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End Sub

Sub FindDuplicates()
 
       ' Declare Current as a worksheet object variable.
         Dim Current As Worksheet
 
 
Dim Dict As Object, aa As Range, arr()
Set Dict = CreateObject("Scripting.Dictionary")
          
         ' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
For Each aa In Sheets(1).Range("H2:I60000") '[H2:I60000]
If aa <> "Сводная" Then
  If Len(aa.Value) > 0 Then
    If Not Dict.exists(aa.Value) Then
      Dict.Add aa.Value, 1
    Else
      Dict.Item(aa.Value) = Dict.Item(aa.Value) + 1
    End If
  End If
End If
Next
Next
 
 
On Error Resume Next
Set aa = Application.InputBox("Select distination cell.", , , , , , , 8)
If aa <> "Сводная" Then
If Err.Number > 0 Then Set aa = [AA1]
On Error GoTo 0
If aa.Cells.Count > 1 Then Set aa = Range(Left(aa.Address, InStr(":", aa.Address) - 1))
aa.Resize(Dict.Count) = Application.Transpose(Dict.keys)
aa.Offset(0, 1).Resize(Dict.Count) = Application.Transpose(Dict.items)
End If
 
End Sub

For Each aa In Current.Range("H2:I60000")

Sub ColorsDoubles()    On Error Resume Next
    ' массив цветов, используемых для заливки ячеек-дубликатов
    Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
                   9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)

    Dim coll As New Collection, dupes As New Collection, _
        cols As New Collection, ra As Range, cell As Range, n&
    Err.Clear: Set ra = Intersect(Selection, ActiveSheet.UsedRange)
    If Err Then Exit Sub

    ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False
    For Each cell In ra.Cells ' запонимаем значение дубликатов в коллекции dupes
    Err.Clear: If Len(Trim(cell)) Then coll.Add CStr(cell.Value), CStr(cell.Value)
        If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value)
    Next cell
    For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов
    n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1
    Next
    For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет
    cell.Interior.Color = cols(CStr(cell.Value)) ' если надо окрасить всю строку,то cell.EntireRow.Interior.color = cols(CStr(cell.Value))
    Next cell
    Application.ScreenUpdating = True
End Sub

Sub ColorsDoubles()
    On Error Resume Next
    ' массив цветов, используемых для заливки ячеек-дубликатов
    Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
                   9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)

    Dim coll As New Collection, dupes As New Collection, _
        cols As New Collection, ra As Range, cell As Range, n&
    For Each oneSheet In ThisWorkbook.Sheets
    Err.Clear: Set ra = worksheet.UsedRange
   Next
    If Err Then Exit Sub

    ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False
    For Each cell In ra.Cells ' запонимаем значение дубликатов в коллекции dupes
    Err.Clear: If Len(Trim(cell)) Then coll.Add CStr(cell.Value), CStr(cell.Value)
        If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value)
    Next cell
    For i& = 1 To dupes.Count ' заполняем коллекцию cols цветами для разных дубликатов
    n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1
    Next
    For Each cell In ra.Cells ' окрашиваем ячейки, если для её значения назначен цвет
    cell.Interior.Color = cols(CStr(cell.Value)) ' если надо окрасить всю строку,то cell.EntireRow.Interior.color = cols(CStr(cell.Value))
    Next cell
    Application.ScreenUpdating = True End Sub