Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1611|回复: 4

[已解决]求高手帮忙做VBA,具体要求见附件

[复制链接]
发表于 2016-6-23 17:11 | 显示全部楼层 |阅读模式
本帖最后由 清秋淡水 于 2016-6-24 09:51 编辑

求高手帮忙做VBA,具体要求见附件,如有不明白,请联系,谢谢。
最佳答案
2016-6-24 08:35
清秋淡水 发表于 2016-6-24 08:31
师傅,你好,你做的报表中有没有一个按钮,点击一下就可以实现?我打开工作表后不知道如何能产生结果?

看附件!

统计表实现.rar

10.66 KB, 下载次数: 18

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2016-6-23 21:04 | 显示全部楼层
本帖最后由 老司机带带我 于 2016-6-23 21:25 编辑

代码如下,结果生产在另外一个表中:
  1. Sub XX()
  2.     Dim str$, arr, brr(), crr, n&, j&, i&, k%, x&
  3.     With Sheet1
  4.         n = .Cells(.Rows.Count, 1).End(xlUp).Row
  5.         arr = .Range("A2:O" & n)
  6.     End With
  7.     x = 1
  8.     ReDim Preserve brr(1 To 15, 1 To x)
  9.     For k = 1 To 15
  10.         brr(k, x) = arr(1, k)
  11.     Next
  12.     For j = 2 To n - 1
  13.         With CreateObject("ScriptControl")
  14.             .Language = "JScript"
  15.             str = .eval("'" & arr(j, 14) & "'.replace(/(\d+)/g,' $1 ');")
  16.             crr = Split(Left(str, Len(str) - 1))
  17.             For i = 0 To UBound(crr) Step 2
  18.                 x = x + 1
  19.                 ReDim Preserve brr(1 To 15, 1 To x)
  20.                 For k = 1 To 13
  21.                     brr(k, x) = arr(j, k)
  22.                 Next
  23.                 brr(14, x) = crr(i)
  24.                 brr(15, x) = crr(i + 1)
  25.             Next
  26.         End With
  27.     Next
  28.     Sheet3.Range("A1").Resize(UBound(brr, 2), 15) = Application.WorksheetFunction.Transpose(brr)
  29. End Sub
复制代码

统计表实现.rar

19.58 KB, 下载次数: 18

回复

使用道具 举报

 楼主| 发表于 2016-6-24 08:31 | 显示全部楼层
老司机带带我 发表于 2016-6-23 21:04
代码如下,结果生产在另外一个表中:

师傅,你好,你做的报表中有没有一个按钮,点击一下就可以实现?我打开工作表后不知道如何能产生结果?
回复

使用道具 举报

发表于 2016-6-24 08:35 | 显示全部楼层    本楼为最佳答案   
清秋淡水 发表于 2016-6-24 08:31
师傅,你好,你做的报表中有没有一个按钮,点击一下就可以实现?我打开工作表后不知道如何能产生结果?

看附件!

统计表实现.rar

20.61 KB, 下载次数: 19

回复

使用道具 举报

 楼主| 发表于 2016-6-24 09:48 | 显示全部楼层
老司机带带我 发表于 2016-6-24 08:35
看附件!

可以了, 非常感谢。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 17:16 , Processed in 0.279012 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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