设为首页收藏本站
简字体切换切换到宽版

ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步，快速开始

快捷登录

搜索
ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › 根据单据号和模版生成收款收据 谢谢
EH技术汇-专业的职场技能充电站 妙哉！函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器，一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理，一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
12下一页
返回列表 发新帖
查看: 6239|回复: 13

[求助] 根据单据号和模版生成收款收据 谢谢

[复制链接]
2821121973

TA的精华主题

TA的得分主题
发表于 2018-6-18 09:44 | 显示全部楼层 |阅读模式
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
大家好，请教一个项目：
根据【明细】中的单据号和【模版】中的收款收据模版，
在工作表【收款收据】中生成N个收款收据。
N等于单据号不重复个数，
如：现在有4个单据号，将会生成4个收款收据。
每个单据号的行数（产品）不会超过5行（5种）。
要是能根据日期进行筛选，
生成对应范围内的M个收款收据就更好了，
M等于筛选后的单据号不重复个数。
因我VBA水平有限，求教大家帮帮忙！
谢谢大家！
收款收据.rar (15.47 KB, 下载次数: 170)





根据, 单据, 模版, 生成, 收款
回复

举报

2821121973

TA的精华主题

TA的得分主题
 楼主| 发表于 2018-6-18 10:45 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
大家是不是都放假过节了，希望大家明天能帮忙帮忙。谢谢。
回复

举报

朱荣兴
头像被屏蔽

TA的精华主题

TA的得分主题
发表于 2018-6-18 11:47 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
提示: 作者被禁止或删除 内容自动屏蔽
回复

举报

2821121973

TA的精华主题

TA的得分主题
 楼主| 发表于 2018-6-18 12:09 | 显示全部楼层
[广告] ★ 对Excel用户最友好的数据分析编程语言，再不发愁Excel计算困难和容量限制 ★
朱荣兴 发表于 2018-6-18 11:47
字典去重复，按模板拆分问题，不难，但是，涉及的细节太多，需要时间和精力，

嗯，谢谢。我再想想办法。
回复

举报

2821121973

TA的精华主题

TA的得分主题
 楼主| 发表于 2018-6-18 15:29 | 显示全部楼层
[广告] ★Excel Home云课堂 - 专业的职场技能充电站★         ★Excel三大利器★        ★ 笨办法学VBA全系列★
现在代码能生成N个收款收据，只差生成对应的数据了！
有哪位高手指点明路，谢谢！

Sub dj_copy()
    Dim d, arr, i, j&
    Set d = CreateObject("scripting.dictionary")

    arr = Range("c2:c" & Cells(Rows.Count, 3).End(3).Row)
   
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = ""
    Next i

    Sheets("收款收据").Cells.Delete

    For j = 1 To 11 * d.Count
        
        Sheets("模版").Range("A1:H10").Copy Sheets("收款收据").Range("A" & j)
        
        j = j + 10
        
    Next j
   
    Sheets("收款收据").Select
   
End Sub

收款收据.rar

27.16 KB, 下载次数: 55
回复

举报

453507254

TA的精华主题

TA的得分主题
发表于 2018-6-18 15:43 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
  1. Sub 收款单据生成()
  2.     Dim d, i%, j%, lastrow%, startrow%, startdate, enddate
  3.     Dim arr1, arr2
  4.     Set d = CreateObject("scripting.dictionary")
  5.     lastrow = Sheets(1).Range("A65536").End(3).Row
  6.     arr1 = Sheets(1).Range("A2:K" & lastrow)
  7.     arr2 = Sheets(2).Range("A1:H10")
  8.     startdate = CDate(InputBox("请输入开始日期：例如2018/1/1", "开始日期"))
  9.     enddate = CDate(InputBox("请输入结束日期：例如2018/12/31", "结束日期"))
  10.     For i = 1 To UBound(arr1)
  11.         If arr1(i, 2) >= startdate And arr1(i, 2) <= enddate Then
  12.             d(CStr(arr1(i, 3))) = ""
  13.         End If
  14.     Next
  15.     With Sheets(4) '这里我新建了一个工作表，如果你想直接在第三个工作表生成结果，把4改成3即可
  16.         .UsedRange.Clear
  17.         For i = 1 To d.Count
  18.             If .Range("A1") = "" And .Range("A2") = "" Then
  19.                 startrow = 2
  20.             Else
  21.                 startrow = .Range("A65536").End(3).Row + 2
  22.             End If
  23.             Sheets(2).Range("A1:H10").Copy
  24.             .Cells(startrow, 1).PasteSpecial Paste:=xlPasteColumnWidths
  25.             .Cells(startrow, 1).PasteSpecial Paste:=xlPasteAll
  26.         Next
  27.         .Rows("1:10000").RowHeight = 25
  28.         d.RemoveAll
  29.         For j = 1 To UBound(arr1)
  30.             If arr1(j, 2) >= startdate And arr1(j, 2) <= enddate Then
  31.                 If Not d.exists(CStr(arr1(j, 3))) Then
  32.                     d(CStr(arr1(j, 3))) = (d.Count) * 11 + 5
  33.                     .Cells((d.Count - 1) * 11 + 3, 1) = .Cells((d.Count - 1) * 11 + 3, 1) & Sheets(1).Cells(j + 1, 1)
  34.                     .Cells((d.Count - 1) * 11 + 3, 4) = .Cells((d.Count - 1) * 11 + 3, 4) & Sheets(1).Cells(j + 1, 2)
  35.                     .Cells((d.Count - 1) * 11 + 3, 7) = .Cells((d.Count - 1) * 11 + 3, 7) & Sheets(1).Cells(j + 1, 3)
  36.                     .Cells((d.Count - 1) * 11 + 5, 1).Resize(1, 8).Value = Sheets(1).Cells(j + 1, 4).Resize(1, 8).Value
  37.                     d(CStr(arr1(j, 3))) = d(CStr(arr1(j, 3))) + 1
  38.                 Else
  39.                     .Cells(d(CStr(arr1(j, 3))), 1).Resize(1, 8).Value = Sheets(1).Cells(j + 1, 4).Resize(1, 8).Value
  40.                     d(CStr(arr1(j, 3))) = d(CStr(arr1(j, 3))) + 1
  41.                 End If
  42.             End If
  43.         Next j
  44.     End With
  45. End Sub
复制代码
代码不够简洁，期待高手

收款收据.rar

31.14 KB, 下载次数: 39
回复

举报

453507254

TA的精华主题

TA的得分主题
发表于 2018-6-18 15:44 | 显示全部楼层
[广告] ★ 对Excel用户最友好的数据分析编程语言，再不发愁Excel计算困难和容量限制 ★
  1. Sub 收款单据生成()
  2.     Dim d, i%, j%, lastrow%, startrow%, startdate, enddate
  3.     Dim arr1, arr2
  4.     Set d = CreateObject("scripting.dictionary")
  5.     lastrow = Sheets(1).Range("A65536").End(3).Row
  6.     arr1 = Sheets(1).Range("A2:K" & lastrow)
  7.     arr2 = Sheets(2).Range("A1:H10")
  8.     startdate = CDate(InputBox("请输入开始日期：例如2018/1/1", "开始日期"))
  9.     enddate = CDate(InputBox("请输入结束日期：例如2018/12/31", "结束日期"))
  10.     For i = 1 To UBound(arr1)
  11.         If arr1(i, 2) >= startdate And arr1(i, 2) <= enddate Then
  12.             d(CStr(arr1(i, 3))) = ""
  13.         End If
  14.     Next
  15.     With Sheets(4) '这里我新建了一个工作表，如果你想直接在第三个工作表生成结果，把4改成3即可
  16.         .UsedRange.Clear
  17.         For i = 1 To d.Count
  18.             If .Range("A1") = "" And .Range("A2") = "" Then
  19.                 startrow = 2
  20.             Else
  21.                 startrow = .Range("A65536").End(3).Row + 2
  22.             End If
  23.             Sheets(2).Range("A1:H10").Copy
  24.             .Cells(startrow, 1).PasteSpecial Paste:=xlPasteColumnWidths
  25.             .Cells(startrow, 1).PasteSpecial Paste:=xlPasteAll
  26.         Next
  27.         .Rows("1:10000").RowHeight = 25
  28.         d.RemoveAll
  29.         For j = 1 To UBound(arr1)
  30.             If arr1(j, 2) >= startdate And arr1(j, 2) <= enddate Then
  31.                 If Not d.exists(CStr(arr1(j, 3))) Then
  32.                     d(CStr(arr1(j, 3))) = (d.Count) * 11 + 5
  33.                     .Cells((d.Count - 1) * 11 + 3, 1) = .Cells((d.Count - 1) * 11 + 3, 1) & Sheets(1).Cells(j + 1, 1)
  34.                     .Cells((d.Count - 1) * 11 + 3, 4) = .Cells((d.Count - 1) * 11 + 3, 4) & Sheets(1).Cells(j + 1, 2)
  35.                     .Cells((d.Count - 1) * 11 + 3, 7) = .Cells((d.Count - 1) * 11 + 3, 7) & Sheets(1).Cells(j + 1, 3)
  36.                     .Cells((d.Count - 1) * 11 + 5, 1).Resize(1, 8).Value = Sheets(1).Cells(j + 1, 4).Resize(1, 8).Value
  37.                     d(CStr(arr1(j, 3))) = d(CStr(arr1(j, 3))) + 1
  38.                 Else
  39.                     .Cells(d(CStr(arr1(j, 3))), 1).Resize(1, 8).Value = Sheets(1).Cells(j + 1, 4).Resize(1, 8).Value
  40.                     d(CStr(arr1(j, 3))) = d(CStr(arr1(j, 3))) + 1
  41.                 End If
  42.             End If
  43.         Next j
  44.     End With
  45. End Sub
复制代码


收款收据.rar

31.14 KB, 下载次数: 33
回复

举报

453507254

TA的精华主题

TA的得分主题
发表于 2018-6-18 16:16 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
本帖最后由 453507254 于 2018-6-18 16:18 编辑

见附件
  1. Sub 收款单据生成()
  2.     Dim d, i%, j%, lastrow%, startrow%, startdate, enddate
  3.     Dim arr1, arr2
  4.     Set d = CreateObject("scripting.dictionary")
  5.     lastrow = Sheets(1).Range("A65536").End(3).Row
  6.     arr1 = Sheets(1).Range("A2:K" & lastrow)
  7.     arr2 = Sheets(2).Range("A1:H10")
  8.     startdate = CDate(InputBox("请输入开始日期：例如2018/1/1", "开始日期"))
  9.     enddate = CDate(InputBox("请输入结束日期：例如2018/12/31", "结束日期"))
  10.     For i = 1 To UBound(arr1)
  11.         If arr1(i, 2) >= startdate And arr1(i, 2) <= enddate Then
  12.             d(CStr(arr1(i, 3))) = ""
  13.         End If
  14.     Next
  15.     With Sheets(4) '这里我新建了一个工作表，如果你想直接在第三个工作表生成结果，把4改成3即可
  16.         .UsedRange.Clear
  17.         For i = 1 To d.Count
  18.             If .Range("A1") = "" And .Range("A2") = "" Then
  19.                 startrow = 2
  20.             Else
  21.                 startrow = .Range("A65536").End(3).Row + 2
  22.             End If
  23.             Sheets(2).Range("A1:H10").Copy
  24.             .Cells(startrow, 1).PasteSpecial Paste:=xlPasteColumnWidths
  25.             .Cells(startrow, 1).PasteSpecial Paste:=xlPasteAll
  26.         Next
  27.         .Rows("1:10000").RowHeight = 25
  28.         d.RemoveAll
  29.         For j = 1 To UBound(arr1)
  30.             If arr1(j, 2) >= startdate And arr1(j, 2) <= enddate Then
  31.                 If Not d.exists(CStr(arr1(j, 3))) Then
  32.                     d(CStr(arr1(j, 3))) = (d.Count) * 11 + 5
  33.                     .Cells((d.Count - 1) * 11 + 3, 1) = .Cells((d.Count - 1) * 11 + 3, 1) & Sheets(1).Cells(j + 1, 1)
  34.                     .Cells((d.Count - 1) * 11 + 3, 4) = .Cells((d.Count - 1) * 11 + 3, 4) & Sheets(1).Cells(j + 1, 2)
  35.                     .Cells((d.Count - 1) * 11 + 3, 7) = .Cells((d.Count - 1) * 11 + 3, 7) & Sheets(1).Cells(j + 1, 3)
  36.                     .Cells((d.Count - 1) * 11 + 5, 1).Resize(1, 8).Value = Sheets(1).Cells(j + 1, 4).Resize(1, 8).Value
  37.                     d(CStr(arr1(j, 3))) = d(CStr(arr1(j, 3))) + 1
  38.                 Else
  39.                     .Cells(d(CStr(arr1(j, 3))), 1).Resize(1, 8).Value = Sheets(1).Cells(j + 1, 4).Resize(1, 8).Value
  40.                     d(CStr(arr1(j, 3))) = d(CStr(arr1(j, 3))) + 1
  41.                 End If
  42.             End If
  43.         Next j
  44.     End With
  45. End Sub
复制代码




收款收据.rar

31.14 KB, 下载次数: 331

评分

1

查看全部评分

回复

举报

2821121973

TA的精华主题

TA的得分主题
 楼主| 发表于 2018-6-18 17:04 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
453507254 发表于 2018-6-18 16:16
见附件

非常感谢您的无私奉献！向您学习！谢谢！
回复

举报

飘过西北

TA的精华主题

TA的得分主题
发表于 2018-6-18 17:45 | 显示全部楼层
[广告] ★ 对Excel用户最友好的数据分析编程语言，再不发愁Excel计算困难和容量限制 ★
本帖最后由 飘过西北 于 2018-6-18 17:47 编辑

Sub 生成收据()
Application.ScreenUpdating = False
Dim i, j, k, m, n, t As Integer
j = 0
Dim arr(100), arr2(6)
Dim str As String
Worksheets("明细").Activate
m = Range("a1").CurrentRegion.Rows.Count
For i = 2 To m
    If str Like "*" & Cells(i, 3) & "*" Then
    str = str
    Else
        str = str & Cells(i, 3)
        arr(j) = Cells(i, 3)
        j = j + 1
    End If
Next
Worksheets("模版").Activate
Rows("11:100000").Delete
For i = 1 To j - 1
    Range("a1:h10").Copy Cells(i * 10 + 1, 1)
Next
For i = 0 To j
    Cells(i * 10 + 2, 8) = arr(i)
Next
For i = 2 To j * 10 - 8 Step 10
    For k = 2 To m
        For n = 2 To 6
            If Worksheets("明细").Cells(k, 3) = Cells(i, 8) And Worksheets("明细").Cells(k, 4) = Cells(i + n, 1) Then
                Cells(i, 2) = Worksheets("明细").Cells(k, 1)
                Cells(i, 5) = Worksheets("明细").Cells(k, 2)
                For t = 5 To 10
                     Cells(i + n, t - 3) = Worksheets("明细").Cells(k, t)
                Next
               
            End If
        Next
        
    Next
     
Next
Application.ScreenUpdating = True
End Sub新建一个“模块”粘贴进去
也是新手，重在参与

回复

举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-11-22 07:57 , Processed in 0.051719 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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