[已解决]数据引用并对比

ms967967

要求对数据中的两行进行对比，找出不同的项，并在备注里填加相应的提示，如附件内容，附件在楼下

最佳答案

月排行榜 / 总排行榜

dsmch

2014-8-16 08:42

问题1,建议用子程序以提高效率
问题2代码

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. On Error Resume Next
   
3. If Not Application.Intersect([d4:e10000], Target) Is Nothing Then
   
4.     With Sheets("数据").Range(Sheets("数据").[a3], Sheets("数据").Cells(Rows.Count, 1).End(xlUp))
   
5.         Set rng1 = .Find(Cells(Target.Row, 4))
   
6.         Set rng = .Find(Cells(Target.Row, 5))
   
7.     End With
   
8.     If Not rng1 Is Nothing And Not rng Is Nothing Then
   
9.         arr = Sheets("数据").Range("a2").CurrentRegion
   
10.         ReDim brr(1 To 1, 1 To 7)
    
11.         x = rng1.Row: y = rng.Row
    
12.         For j = 2 To UBound(arr, 2)
    
13.             If arr(y, j) <> arr(x, j) Then p = p & "," & arr(1, j)
    
14.             brr(1, j - 1) = arr(y, j)
    
15.         Next
    
16.         brr(1, 7) = Mid(p, 2)
    
17.         Cells(Target.Row, 6).Resize(1, 7) = brr
    
18.     End If
    
19. End If
    
20. End Sub

复制代码

跳转到最佳答案楼层

ms967967

对比.rar (8.31 KB, 下载次数: 13)

2014-8-15 22:43 上传

点击文件名下载附件

dsmch

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. On Error Resume Next
   
3. If Not Application.Intersect([d4:e10000], Target) Is Nothing Then
   
4.     Set rng1 = Sheets("数据").Columns(1).Find(Cells(Target.Row, 4))
   
5.     Set rng = Sheets("数据").Columns(1).Find(Cells(Target.Row, 5))
   
6.     If Not rng1 Is Nothing And Not rng Is Nothing Then
   
7.         arr = Sheets("数据").Range("a2").CurrentRegion
   
8.         ReDim brr(1 To 1, 1 To 7)
   
9.         x = rng1.Row: y = rng.Row
   
10.         For j = 2 To UBound(arr, 2)
    
11.             If arr(y, j) <> arr(x, j) Then p = p & "," & arr(1, j)
    
12.             brr(1, j - 1) = arr(y, j)
    
13.         Next
    
14.         brr(1, 7) = Mid(p, 2)
    
15.         Cells(Target.Row, 6).Resize(1, 7) = brr
    
16.     End If
    
17. End If
    
18. End Sub

复制代码

dsmch

………………

ms967967

dsmch 发表于 2014-8-16 05:38
………………

非常感谢您的帮助，你的VBA已经基本达到我的要求，只是在使用时发现两个细节需要调整一下，不知是否可以实现。
1.如果测试表中的D:E两列的内容是一次粘贴上多条，现在后面只能显示出第一行的结果，其它的需要击活一下才能显示，不知能否做到一次显示。
2.当D:E表列是空格时，备注里会显示内容，能否做一个限制，当D和E两格为空时，备注里不显示，

dsmch

问题1,建议用子程序以提高效率
问题2代码

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. On Error Resume Next
   
3. If Not Application.Intersect([d4:e10000], Target) Is Nothing Then
   
4.     With Sheets("数据").Range(Sheets("数据").[a3], Sheets("数据").Cells(Rows.Count, 1).End(xlUp))
   
5.         Set rng1 = .Find(Cells(Target.Row, 4))
   
6.         Set rng = .Find(Cells(Target.Row, 5))
   
7.     End With
   
8.     If Not rng1 Is Nothing And Not rng Is Nothing Then
   
9.         arr = Sheets("数据").Range("a2").CurrentRegion
   
10.         ReDim brr(1 To 1, 1 To 7)
    
11.         x = rng1.Row: y = rng.Row
    
12.         For j = 2 To UBound(arr, 2)
    
13.             If arr(y, j) <> arr(x, j) Then p = p & "," & arr(1, j)
    
14.             brr(1, j - 1) = arr(y, j)
    
15.         Next
    
16.         brr(1, 7) = Mid(p, 2)
    
17.         Cells(Target.Row, 6).Resize(1, 7) = brr
    
18.     End If
    
19. End If
    
20. End Sub

复制代码

ms967967

dsmch 发表于 2014-8-16 08:42
问题1,建议用子程序以提高效率
问题2代码

谢谢您的支持，
　　希望在您方便的时候能将您的VBA语句给解释几条，以方便我能更好的应用。再次谢谢您的支持。

su45

ms967967 发表于 2014-8-16 20:42
谢谢您的支持，
　　希望在您方便的时候能将您的VBA语句给解释几条，以方便我能更好的应用。再次谢谢您的 ...

在VBE中，选择不懂的词，按 F1 键，看帮助！