ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 求教 - 能否利用VBA实现这个转换?

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-12-9 15:44 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
请问能否通过VBA实现这样的转换?

OBJ, FLD, VAL 来自于不同的SOURCE-ID(参左表)
需要实现:当OBJ和FLD相同,则合并VAL。
举例:
蓝色:因BKPF_KOA, ACTVT=03,所以合并VAL为M, AA
黄色:因BKPF_KOA, ACTVT=*,所以合并VAL为D, K
绿色:因BKPF_KOA, ACTVT=02,03,所以合并VAL为S
粉色:因BKPF_BLA,ACTVT包含01,02和03在多行,所以VAL合并为01,02,03

案例模板请参考附件DEMO
DEMO.zip (8.2 KB, 下载次数: 5)


Snap8.png

TA的精华主题

TA的得分主题

发表于 2019-12-9 16:13 | 显示全部楼层
其实VBA处理起来也就是循环一遍,用for ... next语句,
循环中间用判断语句if...then...elseif...语句,
就行了。

TA的精华主题

TA的得分主题

发表于 2019-12-9 16:39 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-12-9 17:03 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
Sub test()

    Dim dic1 As Object, dic2 As Object
    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    Dim rng As Range
    Dim r As Long
    Dim colArr
    With Sheet7
        r = .Range("B2").End(xlDown).Row
        For Each rng In .Range("B3:B" & r)
            dic1(rng.Interior.ColorIndex) = dic1(rng.Interior.ColorIndex)
        Next
        colArr = dic1.keys
        dic1.RemoveAll
        For i = 0 To UBound(colArr)
            For Each rng In .Range("B3:B" & r)
                If colArr(i) = rng.Interior.ColorIndex Then
                    dic1(rng & "," & rng.Offset(0, 1) & "," & rng.Offset(0, 2)) = dic1(rng & "," & rng.Offset(0, 1) & "," & rng.Offset(0, 2))
                End If
            Next
            Dim arr1, arr2, arr3, arr4
            arr1 = dic1.keys
            For j = 0 To UBound(arr1)
                arr2 = Split(arr1(j), ",")
                dic2(arr2(0) & "," & arr2(1)) = dic2(arr2(0) & "," & arr2(1)) & "," & arr2(2)
                Erase arr2
            Next
            arr3 = dic2.keys
            arr4 = dic2.items
            m = .Range("F50000").End(xlUp).Row
            For n = 0 To UBound(arr3)
                .Cells(m + 1 + n, 6) = Split(arr3(n), ",")(0)
                .Cells(m + 1 + n, 7).Interior.ColorIndex = colArr(i)
                .Cells(m + 1 + n, 7) = Split(arr3(n), ",")(1)
                .Cells(m + 1 + n, 8).Interior.ColorIndex = colArr(i)
                .Cells(m + 1 + n, 8) = arr4(n)
            Next
            Erase arr1
            Erase arr2
            Erase arr3
            Erase arr4
            dic1.RemoveAll
            dic2.RemoveAll
        Next
    End With

End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-12-9 17:06 | 显示全部楼层
见附件, 下班前给搞出来了, 哈哈.
合并单元格, 你自己手点下, 或者改改代码吧!

1111111.gif

DEMO.zip

18.91 KB, 下载次数: 6

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-10 14:02 | 显示全部楼层
NadrsSaber 发表于 2019-12-9 17:03
Sub test()

    Dim dic1 As Object, dic2 As Object

非常感谢,试了一下可用。我做一个完整测试给您更新

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-10 14:03 | 显示全部楼层
NadrsSaber 发表于 2019-12-9 17:06
见附件, 下班前给搞出来了, 哈哈.
合并单元格, 你自己手点下, 或者改改代码吧!

感谢,
下载后发现vba丢失,不知道是不是被论坛过滤了?

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-10 14:16 | 显示全部楼层
NadrsSaber 发表于 2019-12-9 17:03
Sub test()

    Dim dic1 As Object, dic2 As Object


@NadrsSaber,测试过程中发现两个错误。不知可否帮忙看下? 非常感谢

1. 当我把值改为02,B的时候,正确的结果应该是单独生成两行(绿框)
2. 目前生成的VAL最前面都会出现","不知何故

Snap6.png

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-10 14:21 | 显示全部楼层
NadrsSaber 发表于 2019-12-9 17:03
Sub test()

    Dim dic1 As Object, dic2 As Object

有个误会可能:代码中貌似按照颜色进行分组,实际无需关注颜色。我用颜色分分组是希望澄清问题,为了让大家看的更清楚。呵呵

TA的精华主题

TA的得分主题

发表于 2019-12-10 14:24 | 显示全部楼层
ccnp_server 发表于 2019-12-10 14:16
@NadrsSaber,测试过程中发现两个错误。不知可否帮忙看下? 非常感谢

1. 当我把值改为02,B的时候, ...

1. 不是很明白为什么又要分开生成2行了, 不是要求的是合并起来的吗?
2. "," 这个在代码里用mid截取一下就行了.
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 12:38 , Processed in 0.058768 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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