Excel表格录入新的数据后自动删除重复的旧数据行,求VBA代码,请高手赐教,谢谢！

Question

跟据B列（物料编码）内容判断，比方说如果新增加在B8单元格编码与之前B2单元格相同编码时，则自动删除B2所在的行（第2行），求高手给VBA代码，最好注释每句代码的意思，谢谢！目的：每个代编只有一条记录，而且是最新记录。

Answer 1

进入vba编辑器，双击如图所示，进入ThisWorkbook代码编辑窗口，复制下面代码

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim i As Integer
i = Application.WorksheetFunction.CountIf(Range("B:B"), Target.Value)
If i > 1 Then Target.Delete xlShiftUp
End Sub

　　Workbook_SheetChange为工作薄内部事件，当用户更改工作表中的单元格或者外部链接引起单元格的更改时，产生此事件。参数Target为发生更改的区域。

　　使用excel内置函数 CountIf 计算区域中满足给定条件的单元格的个数。delete方法删除刚刚修改的范围，xlShiftUp指定删除单元格时替补单元格的移位方式为向上。

追问

代码简洁，但只能删除新增的B列单元格的内容，可我要的是删除旧的数据，保留新数据，另外该代码不能删除目的数据的整行，高手你修改一下看如何？

追答Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim i As Integer
If Target.Columns.Cells.Count > 1 Or Target.Columns.Column <> 2 Then Exit Sub
i = Application.WorksheetFunction.Match(Target, Range("B:B"), 0)
If i > 0 And i < Target.Row Then    Cells(i, 2).EntireRow.Delete xlShiftUp
End Sub

追问

你好，上面代码只能在表格手动键入内容时能够达到删除旧数据的目的，而使用粘贴（整行数据同时粘贴）方法时代码不能执行，再修改一下如何？

追答

应该可以了。如果搞定了请一定要加分哦

'1.代码只针对B列数据
‘2.只会查找重复的第一个数据并删除所在的行
Dim i As Integer, Rng As Range
Set Rng = Cells(Target.Row, 2) '修改的B列单元格
If Rng.Value = "" Then Exit Sub
i = Application.WorksheetFunction.Match(Rng, Range("B:B"), 0)
If i > 0 And i < Target.Row Then
    Application.EnableEvents = False
    Rows(i).Delete xlShiftUp '删除行
    Application.EnableEvents = True
End If

Answer 2

将代码放入 sheet1（sheet1）中JMEYCN已经截图了

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a As Integer
a = Target.Row - 1 '得到填入数据的行数的上一行
If Target.Count > 1 Or Target.Column <> 2 Then  '如果改变的单元格大于1或者列数不是2那么退出程序
Exit Sub
Else
If Sheets(1).Range("b1: b" & a).Find(Target.Value) Is Nothing Then   '查找填入行以上有没有和该单元格相同的值，没有则退出程序否则，将找到的行删除，下行上移
Exit Sub
Else
Sheets(1).Range("b1: b" & a).Find(Target.Value).EntireRow.Delete xlShiftUp
End If
End If
End Sub

 

试下吧 不行的话  HI我

附件  excel 2010版本

 

追问

思路清晰，但代码不能达到预期目的，请高手修改一下如何。

追答

Private Sub Worksheet_Change(ByVal Target As Range)
Dim a As Integer
a = Target.Row - 1 '得到填入数据的行数的上一行
If Target.Count > 1 Or Target.Column <> 2 Or Target.Row <= 1 Then '如果改变的单元格大于1或者列数不是2那么退出程序
Exit Sub
Else
If Sheets(1).Range("b1: b" & a).Find(Target.Value) Is Nothing Then    '查找填入行以上有没有和该单元格相同的值，没有则退出程序否则，将找到的行删除，下行上移
Exit Sub
Else
Sheets(1).Range("b1: b" & a).Find(Target.Value).EntireRow.Delete xlShiftUp
End If
End If
End Sub

 

附件可以运行的  ，你再试试 excel 2010版本的

Answer 3

复制到你要作用的表中
Private Sub Worksheet_Change(ByVal Target As Range)
DIM r As Long, j As Long
If Target.Count = 1 Then
If IsNumeric(Target) Then
With ActiveSheet
j = .[B65536].End(xlUp).Row
If Target.Column <> 2 Or Target.Row > j + 1 And Target.Value = "" Then Exit Sub
For r = 1 To j - 1
If .Cells(r, 2) = Target.Value Then
Application.EnableEvents = False
.Rows(r).Delete
Application.EnableEvents = True
Exit Sub
End If
Next
End With
End If
End If
End Sub追问

不知哪里出了问题，代码没有任何动作

追答

放入 sheet......XXX......中，例如（sheet1或sheet2.........)