Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 228|回复: 4

[已解决] [已解决]用VBA字典实现查找两列数据 对比第二个错在哪里

[复制链接]
发表于 2017-6-19 18:29 | 显示全部楼层 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
本帖最后由 laoau138 于 2017-6-19 21:40 编辑


用VBA字典实现查找两列数据  对比第二个错在哪里



Sub 第一个结果正确()
    Dim arr(), brr(1 To 1000, 1 To 2)
    Dim x, k, h
    Dim d
    Set d = CreateObject("scripting.dictionary")
    arr = Range("A1").CurrentRegion
    For x = 2 To UBound(arr)
        If arr(x, 1) <> "" Then
            k = k + 1
            d(Cells(x, 6).Value & Cells(x, 7).Value) = k
        End If
    Next x

    For x = 2 To UBound(arr)
        If d.exists(arr(x, 1) & arr(x, 2)) Then
            h = d(arr(x, 1) & arr(x, 2))
            brr(h, 1) = arr(x, 3)
            brr(h, 2) = arr(x, 4)
        End If
    Next x
    Range("h2").Resize(UBound(arr), 2) = brr
End Sub



Sub 第二个错在哪里()
    arr = [a1].CurrentRegion
    brr = [f1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(brr)
        d(brr(i, 1) & brr(i, 2)) = i
    Next
    For i = 2 To UBound(arr)
        t = arr(i, 1) & arr(i, 2)
        If d.exists(t) Then
            brr(d(t), 3) = brr(d(t), 3) + 1
            brr(d(t), 4) = brr(d(t), 4) + 1
        End If
    Next
    [f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub




用VBA字典实现查找两列数据 对比第二个错在哪里.rar

10.38 KB, 下载次数: 4

lisachen发布于 2017-6-19 19:42 |显示全部回帖
本帖最后由 lisachen 于 2017-6-19 19:47 编辑

Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents
    brr = [f1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(brr)
        d(brr(i, 1) & brr(i, 2)) = i
    Next
    For i = 2 To UBound(arr)
        t = arr(i, 1) & arr(i, 2)
        If d.exists(t) Then
            brr(d(t), 3) = brr(d(t), 3) + arr(i, 3)
            brr(d(t), 4) = brr(d(t), 4) + arr(i, 4)
        End If
    Next
    [f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub
发表于 2017-6-19 19:42 | 显示全部楼层    本楼为最佳答案   
本帖最后由 lisachen 于 2017-6-19 19:47 编辑

Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents
    brr = [f1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(brr)
        d(brr(i, 1) & brr(i, 2)) = i
    Next
    For i = 2 To UBound(arr)
        t = arr(i, 1) & arr(i, 2)
        If d.exists(t) Then
            brr(d(t), 3) = brr(d(t), 3) + arr(i, 3)
            brr(d(t), 4) = brr(d(t), 4) + arr(i, 4)
        End If
    Next
    [f1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

评分

参与人数 1经验 +9 收起 理由
laoau138 + 9 来学习

查看全部评分

回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-6-19 21:40 | 显示全部楼层
lisachen 发表于 2017-6-19 19:42
Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents

果然是高手
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-6-19 21:41 | 显示全部楼层
lisachen 发表于 2017-6-19 19:42
Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents

结果正确了,
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-6-19 21:41 | 显示全部楼层
lisachen 发表于 2017-6-19 19:42
Sub 第二个()
    arr = [a1].CurrentRegion
    [h2:i7].ClearContents

现在没有问题了
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2017-10-23 21:35 , Processed in 0.078000 second(s), 21 queries , Gzip On, Memcache On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表