For Each oneSheet In ThisWorkbook.Sheets
    Err.Clear: Set ra = worksheet.UsedRange
   Next

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 prDublicat()
    Dim sh As Worksheet
    Dim Dd As Object
    Dim t$, i&, j&, b$
    Set Dd = CreateObject("scripting.dictionary")
    With CreateObject("scripting.dictionary"): .comparemode = 1
        For Each sh In ActiveWorkbook.Sheets
            sh.Activate
            Cells.Interior.Color = xlNone
            If sh.Name = "Дубликаты" Then GoTo SledSh
            a = Cells(1, 1).Resize(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)
            For i = 1 To UBound(a)
                For j = 1 To UBound(a, 2)
                    If IsEmpty(a(i, j)) Then GoTo SledA
                    t = CStr(a(i, j))
                    If .exists(t) Then
                        If .Item(t) <> "" Then
                            s = Split(.Item(t))
                            Sheets(s(0)).Cells(Val(s(1)), Val(s(2))).Interior.Color = vbRed
                        End If
                        sh.Cells(i, j).Interior.Color = vbRed
                        b = .Item(t) & ";" & sh.Name & " " & i & " " & j
                        .Item(t) = ""
                        If Dd.exists(t) Then b = Dd.Item(t) & ";" & b
                        Dd.Item(t) = b
                    Else
                        .Item(t) = sh.Name & " " & i & " " & j
                    End If
SledA:          Next
            Next
SledSh: Next
    End With
    Sheets("Дубликаты").Activate
    If Dd.Count > 0 Then Cells(1).Resize(Dd.Count, 2) = Application.Transpose(Array(Dd.keys, Dd.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

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

...

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) 'Подставляем переменную вместо слова "Артикул"

...