ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[已解决] 借星光老师的文章代码,求一个数据录入系统的VBA代码

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-12-21 12:44 | 显示全部楼层 |阅读模式
本帖最后由 leaveLK 于 2019-12-22 19:52 编辑

前几天看了星光老师的一篇微信文章,觉得正是自己想使用的代码。无奈自己基础太弱,试试把原来代码复制加修改再叠加,结果出现二义性错误,就没辙了。请各路大神指教,要是星光老师看见了更好。
原文地址:
https://mp.weixin.qq.com/s/eVmT5a16RSaOgw8wF-pxUg

我的问题见附件/ 发票报销录入系统.zip (48.29 KB, 下载次数: 23)

有些运算我已经用函数解决了,但是BCDE列还是需要VBA才能解决,请帮忙。
发票报销录入系统 简化.zip (51.65 KB, 下载次数: 10)



补充内容 (2020-1-17 12:37):
求如何处理二个ListBox代码合并问题。附件在4楼。

补充内容 (2020-1-18 09:53):
最新附件在4楼
20200118附件

补充内容 (2020-1-19 10:26):
4楼、42楼的附件是最终版,相信做类似工作的朋友会用得上。感谢YZC51老师五天来不分白昼的解答。另外请版主把此贴状态求助改为已解决。我好像修改不了主贴。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-21 12:47 | 显示全部楼层
前二个工作表是星光老师的,后面二个是我的报表。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-21 16:37 | 显示全部楼层
查看48,附件下载4次。帮帮忙啊。

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-17 12:40 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 leaveLK 于 2020-1-19 10:09 编辑

从其他地方抄了些代码,有些目的达到了,但是有二个ListBox代码重叠处理不了,也不会嵌套。请路过的帮忙修改。
里面问题比较多,不求一次性全部解决,能解决一个是一个。
发票报销录入系统20200117.zip (55.29 KB, 下载次数: 10)
前面一些主要问题已解决,还有少量需要优化代码,请看最新附件。
发票报销录入系统20200118.zip (45.85 KB, 下载次数: 7)
已完善代码,最终版本。
发票报销录入系统最终版.zip (36.79 KB, 下载次数: 22)

TA的精华主题

TA的得分主题

发表于 2020-1-17 14:16 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
leaveLK 发表于 2020-1-17 12:40
从其他地方抄了些代码,有些目的达到了,但是有二个ListBox代码重叠处理不了,也不会嵌套。请路过的帮忙修 ...

请参考

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Column <> 4 Or Target.Row < 4 Then ListBox1.Visible = False: Exit Sub
    '如果选中的单元格不是第2列,或者小于4行,也就是不在目标范围内,则退出程序
    If Target.Columns.Count > 1 Or Target.Rows.Count > 1 Then ListBox1.Visible = False: Exit Sub
    '如果选中的单元格大于1个,则退出程序
    With Sheets("源数据")
        r = .Range("a1:c" & .Cells(Rows.Count, "a").End(xlUp).Row).Value
    End With
    With ListBox1
        '调整位置到单元格处
        .Top = Target(2).Top 'listbox的顶端位置
        .Left = Target.Left + Target.Width 'listbox的左端位置
        .Width = 250 '宽度
        .Height = 150 '高度
        .Visible = True '可见
        '.ColumnHeads = True '显示标题行
        .ColumnCount = 3 '三列
        .ColumnWidths = "50;120" '设置第一列宽度50第二列宽度130……
        .List = r '数据来源
        .MultiSelect = fmMultiSelectMulti '允许通过鼠标点击的方式进行多选
        .ListStyle = fmListStyleOption '选项按钮设置为方形
    End With
End Sub

Private Sub ListBox1_Change()
    Dim i As Long, strMy As String
    With ListBox1
        If .Selected(0) = True Then .Selected(0) = False
        '如果用户选取的是标题行那么撤销选取
        For i = 1 To .ListCount - 1
        '遍历listbox的记录,如果被选中则按换行符合并
            If .Selected(i) = True Then
                strMy = strMy & vbCrLf & .List(i, 0)
                strMy2 = .List(i, 1)
                '取list的第二列
                '无论列还是行的索引都是从0开始的,因此第二列为1
            End If
        Next
    End With
    '数据写入单元格
    ActiveCell.Value = Mid(strMy, 3)
    ActiveCell(1, 2) = strMy2
End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-17 21:56 | 显示全部楼层
YZC51 发表于 2020-1-17 14:16
请参考

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

感谢你的回答,我明白你的意思了,用一个listbox解决问题,我还有几个疑问:
1、请教一下你的修改的代码含义,原来是.Top = Target.Top + Target.Height 'listbox的顶端位置,你将Target.Top 修改为Target(2).Top 有什么含义呢,我试着去掉“(2)”,却也不影响代码执行。
2、请解释一下 strMy2 = .List(i, 1)和ActiveCell(1, 2) = strMy2代码的意思,这个我不太理解所以我改不了。
因为D、E列的效果还差一点点,没有达到我的意图。
我想达到的效果是D列是大类,如果是多选情况下不要显示重复项,E列是明细,勾选了哪些就要全部显示,我做了一个效果图(图片种右小角)如下。请指教。(能添加顿号最好)
效果.jpg

另,我把你的代码合在一起了,还请用现在的代码基础上修改。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
       If Target.Columns.Count > 1 Or Target.Rows.Count > 1 Then Exit Sub
    If Target.Column = 3 Then
        If Target.Offset(0, -1) = Target.Offset(-1, -1) And Target.Offset(0, -1) <> "" And Target = "" Then
            Target.Value = Target.Offset(-1, 0)
        Else: Target.Value = Target.Offset(-1, 0) + 1
        End If
    End If
    If Target.Column < 3 Then
        If Target.Offset(-1, 0).Value <> "" And Target.Value = "" Then
            Target.Value = Target.Offset(-1, 0) + 1
        End If
    End If
    If Target.Column <> 4 Or Target.Row < 3 Then ListBox1.Visible = False: Exit Sub
    '如果选中的单元格不是第3列,或者小于4行,也就是不在目标范围内,则退出程序
    If Target.Columns.Count > 1 Or Target.Rows.Count > 1 Then ListBox1.Visible = False: Exit Sub
    '如果选中的单元格大于1个,则退出程序
               With Sheets("源数据")
        r = .Range("A2:C" & .Cells(Rows.Count, "a").End(xlUp).Row).Value
    End With
    With ListBox1
        '调整位置到单元格处
        .Top = Target.Top + Target.Height 'listbox的顶端位置,去掉(2),不影响显示呢?
        .Left = Target.Left + Target.Width 'listbox的左端位置
        .Width = 150 '宽度
        .Height = 200 '高度
        .Visible = True '可见
        .ColumnHeads = False '不显示标题行
        .ColumnCount = 2 '二列
        .ColumnWidths = "50;100" '设置第一列宽度50第二列宽度100……
        .List = r '数据来源
        .MultiSelect = fmMultiSelectMulti '允许通过鼠标点击的方式进行多选
        .ListStyle = fmListStyleOption '选项按钮设置为方形
    End With
  End Sub

Private Sub ListBox1_Change()
    Dim i As Long, strMy As String
    With ListBox1
        If .Selected(0) = True Then .Selected(0) = False
        '如果用户选取的是标题行那么撤销选取
        For i = 1 To .ListCount - 1
        '遍历listbox的记录,如果被选中则按换行符合并
            If .Selected(i) = True Then
                strMy = strMy & vbCrLf & .List(i, 0)
                strMy2 = .List(i, 1)
                '取list的第二列
                '无论列还是行的索引都是从0开始的,因此第二列为1
            End If
        Next
    End With
    ActiveCell.Value = Mid(strMy, 3)
    ActiveCell(1, 2) = strMy2
    '数据写入单元格
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-17 22:51 | 显示全部楼层
YZC51 发表于 2020-1-17 14:16
请参考

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

我捣鼓了一下,慢慢理解你的代码。

Private Sub ListBox1_Change()
    Dim i As Long, strMy As String
    With ListBox1
        'If .Selected(0) = True Then .Selected(0) = False
        '如果用户选取的是标题行那么撤销选取
        For i = 0 To .ListCount - 1
        '遍历listbox的记录,如果被选中则按换行符合并
            If .Selected(i) = True Then
                strMy = strMy & vbCrLf & .List(i, 0)
                strMy2 = strMy2 & "、" & .List(i, 1)
                '取list的第二列
                '无论列还是行的索引都是从0开始的,因此第二列为1
            End If
        Next
    End With
    ActiveCell.Value = Mid(strMy, 3)
    ActiveCell(1, 2) = strMy2
    '数据写入单元格
End Sub
----------------------------------
用以上代码把E列问题解决了,也加了顿号,但是要怎么才能把最前面那个顿号去掉呢?D列我没有办法,去除重复值的VBA代码我不会。

2.png

TA的精华主题

TA的得分主题

发表于 2020-1-17 23:15 | 显示全部楼层
抱歉!刚看到!
试试

    ActiveCell.Value = Mid(strMy, 3)
    ActiveCell(1, 2) = Mid(strMy2, 2)

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-1-17 23:20 | 显示全部楼层
.Top = Target.Top + Target.Height 'listbox的顶端位置,去掉(2),不影响显示呢?

与上面代码等效

.Top = Target(2).Top  'listbox的顶端位置下移一行?

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-1-18 07:07 来自手机 | 显示全部楼层
leaveLK 发表于 2020-1-17 22:51
我捣鼓了一下,慢慢理解你的代码。

Private Sub ListBox1_Change()

建议你还是把 烟酒 和 差旅费 分开,不要合并成一个金额,做报表时再合并。。。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-11-13 14:22 , Processed in 0.065981 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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