ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 按期间生成对账单

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-13 09:46 | 显示全部楼层

原表地址
http://club.excelhome.net/thread-1493795-3-1.html
是您写的代码.  我觉得很适用,  但我想变动一下:
1,按 I2 单元格与 K2 单元格给出的起止期间生成分表,  起止期间可以变动
2,B2 单元格若为空,则生成所有单位的分表; 若 B2 单元格有具体的名称,
则只生成该单位的分表.   不知我是否说明白了,
本人不懂VBA, 还望老师帮帮忙, 期间对账单.zip (273.94 KB, 下载次数: 13)

TA的精华主题

TA的得分主题

发表于 2020-1-13 10:18 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 micch 于 2020-1-14 11:02 编辑
  1. Sub mictest()
  2.     Application.ScreenUpdating = False
  3.     Application.DisplayAlerts = False
  4.     For Each sh In Sheets
  5.         If InStr("销售明细,回款明细,对账单模板,查询表", sh.Name) = 0 Then
  6.             sh.Delete
  7.         End If
  8.     Next
  9.     Dim d, arr(1 To 9999, 1 To 12), cd, xs, hk, dw$, ks@, js@, i&, k&, r&
  10.         cd = Array(0, 1, 2, 5, 6, 10, 7, 11, 9, 1, 7, 8, 9)
  11.         Set d = CreateObject("scripting.dictionary")
  12.         Set sh = Sheets("对账单模板")
  13.         xs = Sheets("销售明细").UsedRange
  14.         hk = Sheets("回款明细").UsedRange
  15.         With sh
  16.             dw = Replace(Mid(.[a2].Value, 6), "公司", "")
  17.             x = .[g2].Value
  18.             ks = CDate((Mid(Left(x, InStr(x, "-") - 1), 6)))
  19.             js = CDate(Mid(x, InStr(x, "-") + 1))
  20.         End With

  21.         For i = 2 To UBound(xs)
  22.             If InStr(xs(i, 2), dw) And xs(i, 1) >= ks And xs(i, 1) <= js Then
  23.                 d(xs(i, 2)) = d(xs(i, 2)) & " " & i
  24.             End If
  25.         Next i
  26.         For i = 2 To UBound(hk)
  27.             If InStr(hk(i, 3), dw) And hk(i, 1) >= ks And hk(i, 1) <= js Then
  28.                 d(hk(i, 3)) = d(hk(i, 3)) & ";" & i
  29.             End If
  30.         Next i
  31.         For Each x In d.keys
  32.         Sheets.Add after:=Sheets(Sheets.Count)
  33.         With Sheets(Sheets.Count)
  34.             .Name = x
  35.             sh.[a1:l4].Copy .[a1]
  36.             .[a2] = "收货单位:" & x
  37.             ar = Split(d(x))
  38.             k = 0
  39.             For i = 1 To UBound(ar)
  40.                 k = k + 1
  41.                 For j = 1 To 8
  42.                     arr(k, j) = xs(Val(ar(i)), cd(j))
  43.             Next j, i
  44.             r = k
  45.             ar = Split(ar(UBound(ar)), ";")
  46.              k = 0
  47.             For i = 1 To UBound(ar)
  48.                 k = k + 1
  49.                 For j = 9 To 12
  50.                     arr(k, j) = hk(Val(ar(i)), cd(j))
  51.             Next j, i
  52.             r = IIf(k > r, k, r)
  53.             .[a5].Resize(r, 12) = arr
  54.             sh.[a33:l39].Copy .Cells(r + 6, 1)
  55.         End With
  56.         Next
  57.     Application.DisplayAlerts = True
  58.     Application.ScreenUpdating = True
  59. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-13 12:44 | 显示全部楼层

非常感谢!  我不懂VBA, 请把代码放在附件中发上来, 我自已复制不成功.
写了这么多的代码, 您辛苦了!  等您的附件.

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-13 20:28 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

    请 您 帮 帮 忙 !

TA的精华主题

TA的得分主题

发表于 2020-1-13 20:36 | 显示全部楼层
少如 发表于 2020-1-13 20:28
请 您 帮 帮 忙 !

这还有什么会不会用的,直接复制进去,执行代码就行了。
  1. =SUM(INDIRECT("r5c:r[-1]c",))
复制代码


考虑到模板有一行求合计数,公式 应该改一下,因为行数不是固定的。用这个

4.gif

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-14 10:15 | 显示全部楼层
micch 发表于 2020-1-13 20:36
这还有什么会不会用的,直接复制进去,执行代码就行了。

考虑到模板有一行求合计数,公式 应该改一下 ...

我把您的代码复制进来后, 不成功, 请您受累再给看看.
非常感谢! 期间对账单.zip (271.76 KB, 下载次数: 7)

TA的精华主题

TA的得分主题

发表于 2020-1-14 10:31 | 显示全部楼层
少如 发表于 2020-1-14 10:15
我把您的代码复制进来后, 不成功, 请您受累再给看看.
非常感谢!

我是按以前的模板写的,你模板改了,肯定是白写了,懒得改,你就用以前的模板吧,把模板求和那三个单元格的公式改indirect引用,就可以通用了

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-1-14 11:01 | 显示全部楼层
少如 发表于 2020-1-14 10:15
我把您的代码复制进来后, 不成功, 请您受累再给看看.
非常感谢!

按这个模板改一下
  1. Sub mictest()
  2.     Application.ScreenUpdating = False
  3.     Application.DisplayAlerts = False
  4.     For Each sh In Sheets
  5.         If InStr("销售明细,回款明细,对账单模板,查询表", sh.Name) = 0 Then
  6.             sh.Delete
  7.         End If
  8.     Next
  9.     Dim d, arr(1 To 9999, 1 To 12), cd, xs, hk, dw$, ks@, js@, i&, k&, r&
  10.         cd = Array(0, 1, 2, 5, 6, 10, 7, 11, 9, 1, 7, 8, 9)
  11.         Set d = CreateObject("scripting.dictionary")
  12.         Set sh = Sheets("对账单模板")
  13.         xs = Sheets("销售明细").UsedRange
  14.         hk = Sheets("回款明细").UsedRange
  15.         dw = sh.[b2]:        ks = sh.[i2]:        js = sh.[k2]

  16.         For i = 2 To UBound(xs)
  17.             If InStr(xs(i, 2), dw) And xs(i, 1) >= ks And xs(i, 1) <= js Then
  18.                 d(xs(i, 2)) = d(xs(i, 2)) & " " & i
  19.             End If
  20.         Next i
  21.         For i = 2 To UBound(hk)
  22.             If InStr(hk(i, 3), dw) And hk(i, 1) >= ks And hk(i, 1) <= js Then
  23.                 d(hk(i, 3)) = d(hk(i, 3)) & ";" & i
  24.             End If
  25.         Next i
  26.         For Each x In d.keys
  27.         Sheets.Add after:=Sheets(Sheets.Count)
  28.         With Sheets(Sheets.Count)
  29.             .Name = x
  30.             sh.[a1:l4].Copy .[a1]
  31.             .[b2] = x
  32.             ar = Split(d(x))
  33.             k = 0
  34.             For i = 1 To UBound(ar)
  35.                 k = k + 1
  36.                 For j = 1 To 8
  37.                     arr(k, j) = xs(Val(ar(i)), cd(j))
  38.             Next j, i
  39.             r = k
  40.             ar = Split(d(x), ";")
  41.              k = 0
  42.             For i = 1 To UBound(ar)
  43.                 k = k + 1
  44.                 For j = 9 To 12
  45.                     arr(k, j) = hk(ar(i), cd(j))
  46.             Next j, i
  47.             r = IIf(k > r, k, r)
  48.             .[a5].Resize(r, 12) = arr
  49.             sh.[a33:l39].Copy .Cells(r + 6, 1)
  50.         End With
  51.         Next
  52.     Application.DisplayAlerts = True
  53.     Application.ScreenUpdating = True
  54. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-14 11:03 | 显示全部楼层
micch 发表于 2020-1-14 10:31
我是按以前的模板写的,你模板改了,肯定是白写了,懒得改,你就用以前的模板吧,把模板求和那三个单元格 ...

复制代码成功了, 但有点小问题;   产品名称列全是公司名称了, 请您再给看看, 是我哪里复制错了? 期间对账单.zip (301.03 KB, 下载次数: 13)
对账.jpg

TA的精华主题

TA的得分主题

发表于 2020-1-14 13:34 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
少如 发表于 2020-1-14 11:03
复制代码成功了, 但有点小问题;   产品名称列全是公司名称了, 请您再给看看, 是我哪里复制错了?

第10行,cd数组中的2改为4
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 14:54 , Processed in 0.046955 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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