ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 631|回复: 4

VBA拆分数据和填充数据请教大神写下代码

[复制链接]

TA的精华主题

TA的得分主题

发表于 2021-8-25 19:46 | 显示全部楼层 |阅读模式
初始:Sheet1为数据源,Package Details和Package Information两表为空。需求:将Sheet1中A列和B列分别填充到Package Details中B列和D列。需要实现:1.Sheet1中A列的每行数据在Package Details中出现行数为Sheet1中C1的数值(比如30),且在Package Details中D列当填充过来的数据信息每个的第一行填充数据和Sheet1中一致,其他行数(比如29)均填充为数字8;2.将Package Details的A列按B列数据进行依次顺序编号;3.将Package Details中A列编号填充到Package Information中A列,并将DEF三列全部填充为数字6。感谢大神! image.png image.png image.png



拆分填充数据.zip

29.8 KB, 下载次数: 1

TA的精华主题

TA的得分主题

发表于 2021-8-26 10:36 | 显示全部楼层
Sub 填充PackageDetails()
Dim ar As Variant
Dim i As Long
Dim arr()
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:b" & r)
    cs = .[c1]
    If cs = "" Then MsgBox "请输入填充行数!": End
    If Not IsNumeric(cs) Then MsgBox "请输入数值!": End
End With
ReDim arr(1 To UBound(ar) * cs, 1 To 4)
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" And Trim(ar(i, 2)) <> "" Then
        n = n + 1
        arr(n, 1) = n
        arr(n, 2) = ar(i, 1)
        arr(n, 4) = ar(i, 2)
        For s = 1 To cs - 1
            n = n + 1
            arr(n, 1) = n
            arr(n, 2) = ar(i, 1)
            arr(n, 4) = 8
        Next s
    End If
Next i
With Sheets("Package Details")
     rs = .Cells(Rows.Count, 1).End(xlUp).Row
     If rs > 1 Then .Range("a2:d" & rs) = Empty
     .[a2].Resize(n, 4) = arr
End With
MsgBox "ok!"
End Sub

TA的精华主题

TA的得分主题

发表于 2021-8-26 10:37 | 显示全部楼层
原表.rar (15.43 KB, 下载次数: 5)

TA的精华主题

TA的得分主题

发表于 2021-8-26 10:40 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
第一个,第二个问题解决了,第三个问题,非常简单,自己依样画葫芦吧

TA的精华主题

TA的得分主题

 楼主| 发表于 2021-8-28 11:16 | 显示全部楼层
3190496160 发表于 2021-8-26 10:40
第一个,第二个问题解决了,第三个问题,非常简单,自己依样画葫芦吧

收到,感谢老师!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-12-23 19:44 , Processed in 0.028016 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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