[已解决]禁止录入重复数据

神秘风暴

1.表1-表7的B列为发票号，D列为订单号（Sheet表的格式统一）
2.以B列为例：目前应用数据有效性=COUNTIF($B:$B,B3)<2，可使B列录入重复数据时提示不能录入。（同一张Sheet表可行）
3.现要求关联表1-表7的B列数据，禁止录入重复数据。如：表7的B列存在发票号“28355351”，当在表1的B列中录入“28355351”时提示禁止录入。
4.D列订单号如上设置。
5.请大神们帮忙定制VBA程序。谢谢~

最佳答案

月排行榜 / 总排行榜

林木水

2022-1-14 12:38

1. Sub demo()
   
2. Dim wb As Workbook, i As Integer, k As Integer, rg As Range
   
3. Set wb = ThisWorkbook
   
4. Set rg = Selection.Offset(-1, 0)
   
5. For i = 1 To wb.Sheets.Count
   
6.     If InStr(rg.Address, "B") > 0 And rg.Value <> "" Then
   
7.         If wb.Sheets(i).Range("b:b").Find(rg.Value, lookat:=xlWhole) Is Nothing Then
   
8.         Else
   
9.             k = k + 1
   
10.             If k > 1 Then
    
11.                 MsgBox wb.Sheets(i).Name & "的" & wb.Sheets(i).Range("b:b").Find(rg.Value, lookat:=xlWhole).Address & "重复"
    
12.                 rg.Value = ""
    
13.             End If
    
14.         End If
    
15.     ElseIf InStr(rg.Address, "D") > 0 And rg.Value <> "" Then
    
16.         If wb.Sheets(i).Range("d:d").Find(rg.Value, lookat:=xlWhole) Is Nothing Then
    
17.         Else
    
18.             k = k + 1
    
19.             If k > 1 Then
    
20.                 MsgBox wb.Sheets(i).Name & "的" & wb.Sheets(i).Range("d:d").Find(rg.Value, lookat:=xlWhole).Address & "重复"
    
21.                 rg.Value = ""
    
22.             End If
    
23.         End If
    
24.     Else
    
25.     End If
    
26. Next i
    
27. End Sub
    

复制代码

1. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   
2. If Target.Cells.Count = 1 And (Mid(Target.Address, 2, 1) = "B" Or Mid(Target.Address, 2, 1) = "D") And Target.Row > 2 Then
   
3.    Call demo
   
4. End If
   
5. End Sub
   
6. 
   

复制代码

做了一个粗劣的代码，请看下效果

跳转到最佳答案楼层

ahn

如果你的工作表数量固定，那么依然可以考虑使用数据有效性=COUNTIF(B:B,B2)+COUNTIF('2'!B:B,B2)+COUNTIF('3'!B:B,B2)+COUNTIF('4'!B:B,B2)+COUNTIF('5'!B:B,B2)+COUNTIF('6'!B:B,B2)+COUNTIF('7'!B:B,B2)<2
按这个格式修改下其他表格即可。

林木水

1. Sub demo()
   
2. Dim wb As Workbook, i As Integer, k As Integer, rg As Range
   
3. Set wb = ThisWorkbook
   
4. Set rg = Selection.Offset(-1, 0)
   
5. For i = 1 To wb.Sheets.Count
   
6.     If InStr(rg.Address, "B") > 0 And rg.Value <> "" Then
   
7.         If wb.Sheets(i).Range("b:b").Find(rg.Value, lookat:=xlWhole) Is Nothing Then
   
8.         Else
   
9.             k = k + 1
   
10.             If k > 1 Then
    
11.                 MsgBox wb.Sheets(i).Name & "的" & wb.Sheets(i).Range("b:b").Find(rg.Value, lookat:=xlWhole).Address & "重复"
    
12.                 rg.Value = ""
    
13.             End If
    
14.         End If
    
15.     ElseIf InStr(rg.Address, "D") > 0 And rg.Value <> "" Then
    
16.         If wb.Sheets(i).Range("d:d").Find(rg.Value, lookat:=xlWhole) Is Nothing Then
    
17.         Else
    
18.             k = k + 1
    
19.             If k > 1 Then
    
20.                 MsgBox wb.Sheets(i).Name & "的" & wb.Sheets(i).Range("d:d").Find(rg.Value, lookat:=xlWhole).Address & "重复"
    
21.                 rg.Value = ""
    
22.             End If
    
23.         End If
    
24.     Else
    
25.     End If
    
26. Next i
    
27. End Sub
    

复制代码

1. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   
2. If Target.Cells.Count = 1 And (Mid(Target.Address, 2, 1) = "B" Or Mid(Target.Address, 2, 1) = "D") And Target.Row > 2 Then
   
3.    Call demo
   
4. End If
   
5. End Sub
   
6. 
   

复制代码

做了一个粗劣的代码，请看下效果