[已解决]禁止输入重复数据的VBA代码求助

安全网

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 2 And Target.Column < 9 Then
        W = Target.Row
        If Len(Cells(W, 3)) * Len(Cells(W, 4)) * Len(Cells(W, 5)) * Len(Cells(W, 8)) <> 0 And Target.Count = 1 Then
            Application.EnableEvents = False
            ARR = Range("C1:H" & Range("C65536").End(3).Row - 1)
            For I = 1 To UBound(ARR)
                If ARR(I, 1) = Cells(W, 3) And ARR(I, 2) = Cells(W, 4) And ARR(I, 3) = Cells(W, 5) And ARR(I, 6) = Cells(W, 8) Then
                    Range("C" & I & ":H" & I).Interior.ColorIndex = 6
                    If MsgBox("输入数据与第 " & I & " 行相同！是否需要删除？", 4 + 32 + 256) = 6 Then
                        Rows(W).Delete
                        Range("C2:H" & I).Interior.ColorIndex = 0
                    End If
                    'Exit For
                End If
            Next
            Application.EnableEvents = True
        End If
    End If
End Sub这个代码提示了输入重复数据时提示，但要修改已经输入的数据时，就会提示与本行数据重复

最佳答案

月排行榜 / 总排行榜

zjdh

2016-1-8 16:50

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 2 And Target.Column < 9 Then
        W = Target.Row
        If Len(Cells(W, 3)) * Len(Cells(W, 4)) * Len(Cells(W, 5)) * Len(Cells(W, 8)) <> 0 And Target.Count = 1 Then
            Application.EnableEvents = False
            Arr = Range("C1:H" & Range("C65536").End(3).Row )
            For I = 1 To UBound(Arr)
                If Arr(I, 1) = Cells(W, 3) And Arr(I, 2) = Cells(W, 4) And Arr(I, 3) = Cells(W, 5) And Arr(I, 6) = Cells(W, 8) Then
                    If Target.Row = I Then GoTo 10
                    Range("C" & I & ":H" & I).Interior.ColorIndex = 6
                    If MsgBox("输入数据与第 " & I & " 行相同！是否需要删除？", 4 + 32 + 256) = 6 Then
                        Rows(W).Delete
                        Range("C2:H" & I).Interior.ColorIndex = 0
                    End If
                    'Exit For
                End If
            Next
        End If
    End If
10  Application.EnableEvents = True
End Sub

跳转到最佳答案楼层

安全网

对于已经输入的数据，我需要修改就会出现这样的提示，提示跟本行不重复，。

zjdh

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 2 And Target.Column < 9 Then
        W = Target.Row
        If Len(Cells(W, 3)) * Len(Cells(W, 4)) * Len(Cells(W, 5)) * Len(Cells(W, 8)) <> 0 And Target.Count = 1 Then
            Application.EnableEvents = False
            Arr = Range("C1:H" & Range("C65536").End(3).Row )
            For I = 1 To UBound(Arr)
                If Arr(I, 1) = Cells(W, 3) And Arr(I, 2) = Cells(W, 4) And Arr(I, 3) = Cells(W, 5) And Arr(I, 6) = Cells(W, 8) Then
                    If Target.Row = I Then GoTo 10
                    Range("C" & I & ":H" & I).Interior.ColorIndex = 6
                    If MsgBox("输入数据与第 " & I & " 行相同！是否需要删除？", 4 + 32 + 256) = 6 Then
                        Rows(W).Delete
                        Range("C2:H" & I).Interior.ColorIndex = 0
                    End If
                    'Exit For
                End If
            Next
        End If
    End If
10  Application.EnableEvents = True
End Sub

安全网

zjdh 发表于 2016-1-8 16:50
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 2 And Target.Column < 9  ...

如果能实现对之前多个填充颜色的重复项，去掉其填充颜色就更加完美了。

zjdh

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 2 And Target.Column < 9 Then
        W = Target.Row
        If Len(Cells(W, 3)) * Len(Cells(W, 4)) * Len(Cells(W, 5)) * Len(Cells(W, 8)) <> 0 And Target.Count = 1 Then
            Application.EnableEvents = False
            Arr = Range("C1:H" & Range("C65536").End(3).Row)
            For I = 1 To UBound(Arr)
                If Arr(I, 1) = Cells(W, 3) And Arr(I, 2) = Cells(W, 4) And Arr(I, 3) = Cells(W, 5) And Arr(I, 6) = Cells(W, 8) Then
                    If Target.Row = I Then GoTo 10
                    Range("C" & I & ":H" & I).Interior.ColorIndex = 6
                    If MsgBox("输入数据与第 " & I & " 行相同！是否需要删除？", 4 + 32 + 256) = 6 Then
                        Rows(W).Delete
                        Range("C2:H" & UBound(Arr)).Interior.ColorIndex = 0
                    End If
                    'Exit For
                End If
            Next
        End If
    End If
10  Application.EnableEvents = True
End Sub

安全网

zjdh 发表于 2016-1-8 17:54
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 2 And Target.Column < 9  ...

真不好意思！测试使用的时候又遇到一个这样的问题。不知道能不能解决，具体见图片

安全网

安全网 发表于 2016-1-9 08:35
真不好意思！测试使用的时候又遇到一个这样的问题。不知道能不能解决，具体见图片

提示删除第8行数据，删除了第8行数据，如果第9行是空的就会出现这样的提示

zjdh

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim RN As Range
    If Target.Column > 2 And Target.Column < 9 Then
        W = Target.Row
        If Len(Cells(W, 3)) * Len(Cells(W, 4)) * Len(Cells(W, 5)) * Len(Cells(W, 8)) <> 0 And Target.Count = 1 Then
            Arr = Range("C1:H" & Range("C65536").End(3).Row)
            For I = 1 To UBound(Arr)
                If Arr(I, 1) = Cells(W, 3) And Arr(I, 2) = Cells(W, 4) And Arr(I, 3) = Cells(W, 5) And Arr(I, 6) = Cells(W, 8) Then
                    If W = I Then GoTo 10
                    If RN Is Nothing Then Set RN = Range("C" & I & ":H" & I) Else Set RN = Union(RN, Range("C" & I & ":H" & I))
                    R = R & "," & I
                End If
10          Next
            Application.EnableEvents = False
            RN.Interior.ColorIndex = 6
            If MsgBox("输入数据与第 " & Mid(R, 2) & " 行相同！是否需要删除？", 4 + 32 + 256) = 6 Then
                RN.Delete
                Range("C2:H" & I).Interior.ColorIndex = 0
            End If
        End If
    End If
    Application.EnableEvents = True
End Sub

安全网

zjdh 发表于 2016-1-9 09:51
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim RN As Range
    If Target.Column > 2 An ...

谢谢！非常感谢！个别地方结合前面的我修改了下代码达到我需求的。

安全网

zjdh 发表于 2016-1-9 09:51
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim RN As Range
    If Target.Column > 2 An ...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Row < 3 Then Exit Sub


If Target.Column = 4 Then
Dim j
If Target <> "" Then
On Error Resume Next
j = WorksheetFunction.Match(Target, Sheets("编码").Range("a:a"), 0)
    Cells(Target.Row, 6) = Sheets("编码").Cells(j, 2)
Else
    Cells(Target.Row, 6) = ""
End If
End If


If Target.Column = 2 Then
Dim n
If Target <> "" Then
    Cells(Target.Row, 7) = Format(Target, "yymm" & "月")
Else
    Cells(Target.Row, 7) = ""
End If
End If


   Dim RN As Range
    If Target.Column > 2  and Target.Column <9 Then
        W = Target.Row
        If Len(Cells(W, 3)) * Len(Cells(W, 4)) * Len(Cells(W, 5)) * Len(Cells(W, 8)) <> 0 Then
            Arr = Range("C1:H" & Range("C65536").End(3).Row)
            For I = 1 To UBound(Arr)
                If Arr(I, 1) = Cells(W, 3) And Arr(I, 2) = Cells(W, 4) And Arr(I, 3) = Cells(W, 5) And Arr(I, 6) = Cells(W, 8) Then
                    If W = I Then GoTo 10
                    If RN Is Nothing Then Set RN = Range("C" & I & ":H" & I) Else Set RN = Union(RN, Range("C" & I & ":H" & I))
                    R = R & "," & I
                End If
10          Next
            Application.EnableEvents = False
            RN.Interior.ColorIndex = 6
            If MsgBox("输入数据与第 " & Mid(R, 2) & " 行相同！是否需要删除输入的数据？", 4 + 32 + 256) = 6 Then
                Rows(W).ClearContents
                RN.Interior.ColorIndex = 0
            End If
        End If
    End If
    Application.EnableEvents = True
End Sub
加入上面红色的代码后，因为第4列由使用2次激活，就会出现图示的错误，怎么修改VBA避免错误