ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 189|回复: 9

[求助] 数据提取填充的有一段代码达不到效果,怎么修改?

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-7-23 12:50 | 显示全部楼层 |阅读模式
我有一张数据量较大的总表,需要根据证件号码这一关键字段,将该表的相关信息提取填充到另一张表中的相应列(有些列是挨着的,有些列是分开的,但都在证件号码的右侧),需要的数据能全部填充,但不能准确填充到相应列中去。这段代码需要怎么改?求大神相助!

For i = 2 To UBound(arr)
        d(arr(i, 29)) = Array(arr(i, 9), arr(i, 70), arr(i, 1), arr(i, 4), arr(i, 36))     'arr(i, 29)为证件号,arr(i, 9)为部门,arr(i, 70)为工龄,arr(i, 1)为姓名,arr(i, 4)为性别,arr(i, 36)为职务
    Next

    Sheets("结果").Activate
    .......
    .......
    For i = 1 To UBound(brr)
        For Each s In d.keys
        If StrComp(brr(i, 1), s) = 0 Then
            crr(i, 1) = d(s)(0)
            crr(i, 2) = d(s)(1)
            crr(i, 3) = d(s)(2)
            crr(i, 4) = d(s)(3)
            crr(i, 5) = d(s)(4)
        End If
        Next
    Next

    [AE2].Resize(UBound(crr), 5).ClearContents
    [AE2].Resize(UBound(crr), 5) = crr

资源表提取数据到结果表相应列.rar

27.4 KB, 下载次数: 3

TA的精华主题

TA的得分主题

发表于 2019-7-23 13:40 | 显示全部楼层
  1. Sub 根据证件号填写()
  2.     Set d = CreateObject("Scripting.Dictionary")
  3.     With Sheets("数据源")
  4.         lr1 = .[P65536].End(3).Row
  5.         arr = .Range("P1:CG" & lr1)
  6.     End With
  7.     For i = 2 To UBound(arr)
  8.         s = Trim(arr(i, 29))
  9.         d(s) = Array(arr(i, 9), arr(i, 70), arr(i, 1), arr(i, 4), arr(i, 36))
  10.     Next
  11.     With Sheets("结果")
  12.         lr2 = .[AD65536].End(3).Row
  13.         brr = .Range(Cells(2, "AD"), Cells(lr2, "AL"))
  14.         For i = 1 To UBound(brr)
  15.             s = Trim(brr(i, 1))
  16.             brr(i, 2) = d(s)(0)
  17.             brr(i, 5) = d(s)(1)
  18.             brr(i, 6) = d(s)(2)
  19.             brr(i, 7) = d(s)(3)
  20.             brr(i, 9) = d(s)(4)
  21.        Next
  22.        .[AE2].Resize(UBound(brr), UBound(brr, 2)).ClearContents
  23.        .Range(Cells(2, "AD"), Cells(lr2, "AL")) = brr
  24.     End With
  25. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2019-7-23 13:43 | 显示全部楼层
学会“评分”,问题很快得到解答!

TA的精华主题

TA的得分主题

发表于 2019-7-23 13:44 | 显示全部楼层
代码需要审核,先测试参考附件:

资源表提取数据到结果表相应列.rar

29.96 KB, 下载次数: 5

评分

参与人数 1鲜花 +2 收起 理由
zhangjianiam + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-7-23 16:09 | 显示全部楼层
非常感谢大师的指点,问题已经解决了。我才开始学习VBA,好多代码看得晕乎乎的。谢谢老师了!

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-7-23 23:14 | 显示全部楼层
再问一下,结果表里的证件号,一旦与数据源中的证件号不一致或数据类型不同,都会提示:运行时错误”13“,类型不匹配。
这种情况怎样才能解决呢?请大师再指点一下,谢谢!

TA的精华主题

TA的得分主题

发表于 2019-7-25 16:26 | 显示全部楼层
zhangjianiam 发表于 2019-7-23 23:14
再问一下,结果表里的证件号,一旦与数据源中的证件号不一致或数据类型不同,都会提示:运行时错误”13“, ...

代码稍作修改即可:
  1. Sub 根据证件号填写()
  2.     Set d = CreateObject("Scripting.Dictionary")
  3.     With Sheets("数据源")
  4.         lr1 = .[P65536].End(3).Row
  5.         arr = .Range("P1:CG" & lr1)
  6.     End With
  7.     For i = 2 To UBound(arr)
  8.         s = Val(Trim(arr(i, 29)))
  9.         d(s) = Array(arr(i, 9), arr(i, 70), arr(i, 1), arr(i, 4), arr(i, 36))
  10.     Next
  11.     With Sheets("结果")
  12.         lr2 = .[AD65536].End(3).Row
  13.         brr = .Range(Cells(2, "AD"), Cells(lr2, "AL"))
  14.         For i = 1 To UBound(brr)
  15.             s = Val(Trim(brr(i, 1)))
  16.             If d.exists(s) Then
  17.                 brr(i, 2) = d(s)(0)
  18.                 brr(i, 5) = d(s)(1)
  19.                 brr(i, 6) = d(s)(2)
  20.                 brr(i, 7) = d(s)(3)
  21.                 brr(i, 9) = d(s)(4)
  22.             End If
  23.        Next
  24.        .[AE2].Resize(UBound(brr), UBound(brr, 2)).ClearContents
  25.        .Range(Cells(2, "AD"), Cells(lr2, "AL")) = brr
  26.     End With
  27. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2019-7-25 16:28 | 显示全部楼层
zhangjianiam 发表于 2019-7-23 23:14
再问一下,结果表里的证件号,一旦与数据源中的证件号不一致或数据类型不同,都会提示:运行时错误”13“, ...

代码审核中,先测试参考附件:

资源表提取数据到结果表相应列.rar

28.89 KB, 下载次数: 8

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-7-25 23:46 | 显示全部楼层
lsc900707,老师费心了,很是感谢。这几天通过大家的帮助和提供的代码,对VBA语言、属性有了那么一点点认识了。有花了给老师再补上哈!

TA的精华主题

TA的得分主题

发表于 2019-7-26 13:52 | 显示全部楼层
Sub 证件号()
Dim rng As Range
arr = Sheet9.Range("a1").CurrentRegion
r = [ad65536].End(xlUp).Row
For j = 1 To UBound(arr, 2)
    If arr(2, j) <> "" Then
        k = k + 1
    End If
Next j
    ReDim brr(1 To UBound(arr), 1 To k)
    For i = 1 To UBound(arr)
        m = 0
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                m = m + 1
                If m > k Then Exit For
                brr(i, m) = arr(i, j)
            End If
        Next j
    Next i
    ReDim crr(1 To UBound(brr), 1 To k)
    For Each rng In Range("ad2:ad" & r)
        For i = 2 To UBound(brr)
            If brr(i, 4) = rng Then
                s = s + 1
                crr(s, 1) = brr(i, 4)
                crr(s, 2) = brr(i, 3)
                crr(s, 3) = brr(i, 6)
                crr(s, 4) = brr(i, 1)
                crr(s, 5) = brr(i, 2)
                crr(s, 6) = brr(i, 5)
            End If
        Next i
    Next rng
    [ad2].Resize(UBound(crr), 6) = crr
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-4-7 22:10 , Processed in 0.085642 second(s), 20 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

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