[已解决]用Picture显示数据学习

cunfu2010

如题，附件中如何将msgbox中显示的内容通过Picture显示

最佳答案

月排行榜 / 总排行榜

望帝春心

2016-11-14 14:57

cunfu2010 发表于 2016-11-14 14:32
谢谢关注，显示是实现了，但显示的内容与工作表中重复数据对不上，且显示了好多遍。怎么修改

1. Sub zz()
   
2.     Dim d, d1, ar, crr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Sheet1.UsedRange.Cells.Interior.ColorIndex = 0
   
6.     ar = Range("C1:C" & [c65536].End(3).Row)
   
7.     On Error Resume Next
   
8.     For i = 1 To UBound(ar)
   
9.         If ar(i, 1) <> "" Then d(ar(i, 1)) = d(ar(i, 1)) + 1
   
10.     Next
    
11.     For i = 1 To UBound(ar)
    
12.         If d(Cells(i, 3).Value) > 1 Then
    
13.             Cells(i, 3).Interior.ColorIndex = 3
    
14.             d1(Cells(i, 3).Value) = d1(Cells(i, 3).Value) & " " & Cells(i, 3).Address(0, 0)
    
15.         End If
    
16.     Next
    
17.     For Each k In d.keys
    
18.         If d(k) > 1 Then s = s & "数据：" & k & "  重复次数：" & d(k) & "  单元格：" & d1(k) & Chr(10)
    
19.     Next
    
20.     If s <> "" Then
    
21.     'MsgBox s
    
22.     crr = Split(s, "Chr(10)")
    
23.     For i = 0 To UBound(crr)
    
24.     m = crr(i)
    
25.      With Range("aa1").Resize(UBound(crr) + 1, 1)
    
26.         .Value = m
    
27.         .Columns.AutoFit
    
28.         .BorderAround 1, xlThin
    
29.         .Interior.ColorIndex = 2
    
30.         .CopyPicture xlScreen, xlPicture
    
31.         .Clear
    
32.     End With
    
33.     ActiveSheet.Pictures.Paste.Select
    
34.     Next
    
35.     End If
    
36. End Sub

复制代码

跳转到最佳答案楼层

望帝春心

这段代码不是已经实现了吗？不懂...

cunfu2010

望帝春心 发表于 2016-11-14 14:21
这段代码不是已经实现了吗？不懂...

谢谢关注，显示是实现了，但显示的内容与工作表中重复数据对不上，且显示了好多遍。怎么修改

望帝春心

cunfu2010 发表于 2016-11-14 14:32
谢谢关注，显示是实现了，但显示的内容与工作表中重复数据对不上，且显示了好多遍。怎么修改

1. Sub zz()
   
2.     Dim d, d1, ar, crr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Sheet1.UsedRange.Cells.Interior.ColorIndex = 0
   
6.     ar = Range("C1:C" & [c65536].End(3).Row)
   
7.     On Error Resume Next
   
8.     For i = 1 To UBound(ar)
   
9.         If ar(i, 1) <> "" Then d(ar(i, 1)) = d(ar(i, 1)) + 1
   
10.     Next
    
11.     For i = 1 To UBound(ar)
    
12.         If d(Cells(i, 3).Value) > 1 Then
    
13.             Cells(i, 3).Interior.ColorIndex = 3
    
14.             d1(Cells(i, 3).Value) = d1(Cells(i, 3).Value) & " " & Cells(i, 3).Address(0, 0)
    
15.         End If
    
16.     Next
    
17.     For Each k In d.keys
    
18.         If d(k) > 1 Then s = s & "数据：" & k & "  重复次数：" & d(k) & "  单元格：" & d1(k) & Chr(10)
    
19.     Next
    
20.     If s <> "" Then
    
21.     'MsgBox s
    
22.     crr = Split(s, "Chr(10)")
    
23.     For i = 0 To UBound(crr)
    
24.     m = crr(i)
    
25.      With Range("aa1").Resize(UBound(crr) + 1, 1)
    
26.         .Value = m
    
27.         .Columns.AutoFit
    
28.         .BorderAround 1, xlThin
    
29.         .Interior.ColorIndex = 2
    
30.         .CopyPicture xlScreen, xlPicture
    
31.         .Clear
    
32.     End With
    
33.     ActiveSheet.Pictures.Paste.Select
    
34.     Next
    
35.     End If
    
36. End Sub

复制代码

cunfu2010

望帝春心 发表于 2016-11-14 14:57

With Range("aa1").Resize(UBound(crr) + 1, 1)
为什么UBound(crr) + 1 就可以了？怎么理解？最大值加1？

望帝春心

cunfu2010 发表于 2016-11-14 15:23
With Range("aa1").Resize(UBound(crr) + 1, 1)
为什么UBound(crr) + 1 就可以了？怎么理解？最大值加1 ...

split后数组下标是从0开始的

cunfu2010

望帝春心 发表于 2016-11-14 15:25
split后数组下标是从0开始的

谢谢，学习了。

望帝春心

cunfu2010 发表于 2016-11-14 15:33
谢谢，学习了。

不客气，如有帮助还请评一下最佳...

cunfu2010

望帝春心 发表于 2016-11-14 15:36
不客气，如有帮助还请评一下最佳...

好。另外，我改了代码，提示类型不匹配。再看看
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 2 Or Target.Column = 3 Then
    Dim d, d1, ar, g
    Dim i As Long, k As Long
    Dim arr, brr, crr
    Dim rng As Range
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Me.UsedRange.Cells.Interior.ColorIndex = 0
    ar = Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp))
    For i = 1 To UBound(ar)
        If ar(i, 1) <> "" Then d(ar(i, 1)) = d(ar(i, 1)) + 1
    Next
    For i = 2 To UBound(ar) + 1
        If d(Cells(i, 3).Value) > 1 Then
            Cells(i, 3).Interior.ColorIndex = 3
            d1(Cells(i, 3).Value) = d1(Cells(i, 3).Value) & " " & Cells(i, 3).Address(0, 0)
        Else
            ActiveSheet.Pictures.Delete
        End If
    Next
    For Each g In d.keys
        If d(g) > 1 Then
        n = 0
        Cells(1 + n, "F") = "数据：" & g & "  重复次数：" & d(g) & "  单元格：" & d1(g)
        n = n + 1
        Else
        Cells(1 + n, "F") = ""
        n = n + 1
        End If
    Next
    crr = [F2].CurrentRegion
    With Range("H1").Resize(UBound(crr), 1)
       .Value = crr
       .Columns.AutoFit
       .BorderAround 1, xlThin
       .Interior.ColorIndex = 2
       .CopyPicture xlScreen, xlPicture
       .Clear
       Target.Cells(1, .Columns.Count).Select
    End With
    ActiveSheet.Pictures.Paste
    End If
End Sub