VBA----查找 Excel 表每个sheet的第1列，是否存在重复值

 

代码准备放到关闭表前，报错

 

 

 

这个代码还有点问题

 

Sub jackxxx1()


'先撸有几张表，表名存入数组中
Dim arr1()
Dim arr2()
Dim dic1 As Object



k = 0
wkn1 = ThisWorkbook.Name
Set dic1 = CreateObject("scripting.dictionary")


For Each sh1 In Workbooks(wkn1).Sheets
   ReDim arr1(k)
   arr1(k) = sh1.Name
   k = k + 1
Next

'先撸有几张表，每张英文表名的第1列，都要检查重复，这里得写循环




'第1列先存进去

arr2() = Range("a1" & ":" & "a" & Range("a65535").End(xlUp).Row)


k1 = dic1.keys
it1 = dic1.items

For Each sh1 In Workbooks(wkn1).Sheets
    For i = 1 To UBound(arr2(), 1)
       dic1(arr2(i, 1)) = dic1(arr2(i, 1)) + 1
'       If dic1(arr2(i, 1)) >= 0 Then
'          Cells(i, 1).Interior.ColorIndex = 6
'       End If
    Next i
Next



'For Each x In dic1.keys()
'        Debug.Print dic1.k1(x)
'Next x
'
'
'For Each y In dic1.items()
'        Debug.Print dic1.it1(y)
'Next y




'x12 = dic1.keys.Count
'For x11 = 0 To (x12 - 1)
'   Debug.Print dic1.keys()(x11)
'   Debug.Print dic1.items()(x11)
'   Debug.Print ""
'Next





'k1 = dic1.keys
'it1 = dic1.items
'For Each j In it1
'  If j >= 2 Then
'
''    x1 = it1(m)
''    m = m + 1
''    MsgBox x1
''   MsgBox k1(Application.Match(it1(j), it1, 0) - 1)
''  MsgBox dic1.keys(Application.Match(dic1.items(j), dic1.items, 0))
'
' '改颜色
'
' '通知
'  MsgBox "存在重复值"
'  '退出
'  Exit Sub
'  End If
'Next j


For Each j In dic1.items
  If j >= 2 Then
  MsgBox "存在重复值"
  Exit Sub
  End If
Next j


'指定某几个表的，某一列，需要特别查ID引用是否为空的问题


End Sub