ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 351|回复: 5

[求助] 不知如何下手,求助老师

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-12-16 22:15 | 显示全部楼层 |阅读模式
老师,报表有点复杂,能否一键生成呢?请给予帮助。

生成数据表.rar

18.21 KB, 下载次数: 12

TA的精华主题

TA的得分主题

发表于 2019-12-16 23:08 | 显示全部楼层
ni z你这东西适合用透视表

TA的精华主题

TA的得分主题

发表于 2019-12-17 08:40 | 显示全部楼层
'这种代码偶尔敲一次还是可以的,练练眼力,,,

Option Explicit

Sub test()
  Dim arr, i, j, k, p, t, m, n, sum, total, cnt
  arr = Sheets("数据").[a1].CurrentRegion.Offset(1).Resize(, 4)
  ReDim brr(1 To UBound(arr, 1) * 2, 1 To 10)
  ReDim sum(1 To UBound(brr, 2)), total(1 To UBound(brr, 2))
  ReDim pos(1 To UBound(arr, 1), 1 To 2), temp(1 To UBound(brr, 2))
  Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1, True)
  For i = 1 To UBound(arr, 1) - 1
    If arr(i, 1) <> arr(i + 1, 1) Then
      Call bsort(arr, p + 1, i, 1, UBound(arr, 2), 2, True)
      cnt = cnt + 1: pos(cnt, 1) = m + 1
      For j = p + 1 To i
        sum(5) = sum(5) + arr(j, 3): sum(7) = sum(7) + arr(j, 4)
        total(5) = total(5) + arr(j, 3): total(7) = total(7) + arr(j, 4)
        If arr(j, 1) <> arr(j + 1, 1) Or arr(j, 2) <> arr(j + 1, 2) Then
          m = m + 1
          brr(m, 1) = arr(i, 1): brr(m, 4) = arr(j, 2)
          brr(m, 5) = sum(5): brr(m, 7) = sum(7)
          brr(m, 9) = brr(m, 5) - brr(m, 7)
          sum(5) = 0: sum(7) = 0: p = j
        End If
      Next
      pos(cnt, 2) = m
      m = m + 1
      brr(m, 1) = arr(i, 1): brr(m, 4) = "小计"
      brr(m, 5) = total(5): brr(m, 6) = 1
      brr(m, 7) = total(7): brr(m, 8) = 1
      brr(m, 9) = brr(m, 5) - brr(m, 7)
      brr(m, 10) = Round(brr(m, 9) / brr(m, 7), 2)
      temp(5) = temp(5) + total(5): temp(7) = temp(7) + total(7)
      temp(9) = temp(9) + brr(m, 9)
      total(5) = 0: total(7) = 0
      Call bsort(brr, pos(cnt, 1), pos(cnt, 2), 1, UBound(brr, 2), 5, False)
      Call rank(brr, pos(cnt, 1), pos(cnt, 2), 5, 3, True)
      For j = pos(cnt, 1) To pos(cnt, 2)
        brr(j, 6) = Round(brr(j, 5) / brr(pos(cnt, 2) + 1, 5), 3)
        brr(j, 8) = Round(brr(j, 7) / brr(pos(cnt, 2) + 1, 7), 3)
        brr(j, 10) = Round(brr(j, 9) / brr(j, 7), 3)
      Next
      p = i
    End If
  Next
  m = m + 1
  brr(m, 1) = "总计": brr(m, 5) = temp(5): brr(m, 7) = temp(7): brr(m, 9) = temp(9)
  brr(m, 10) = Round(brr(m, 9) / brr(m, 7), 2)
  For i = 1 To cnt - 1
    For j = i + 1 To cnt
      If brr(pos(i, 2) + 1, 10) < brr(pos(j, 2) + 1, 10) Then
        t = pos(i, 1): pos(i, 1) = pos(j, 1): pos(j, 1) = t
        t = pos(i, 2): pos(i, 2) = pos(j, 2): pos(j, 2) = t
      End If
    Next
  Next
  arr = brr: m = 0
  For i = 1 To cnt
    n = n + 1
    For j = pos(i, 1) To pos(i, 2) + 1
      m = m + 1
      For k = 1 To UBound(brr, 2)
        arr(m, k) = brr(j, k)
      Next
      arr(m, 2) = n
    Next
    arr(m, 2) = vbNullString
  Next
  Call doevent(False)
  With Sheets("生成报表")
    .[a2].Resize(UBound(arr, 1) * 2, UBound(arr, 2)).Clear
    For i = 6 To 10 Step 2
      .Cells(2, i).Resize(m + 1).NumberFormatLocal = "0.0%"
    Next
    With .[a2].Resize(m + 1, UBound(arr, 2))
      .Value = arr
      .Borders.LineStyle = xlContinuous
    End With
    p = 2
    For i = 2 To .Cells(Rows.Count, "d").End(xlUp).Row
      If .Cells(i, "d").Value = "小计" Then
        .Cells(p, "a").Resize(i - p + 1).Merge '这行可注释掉
        .Cells(p, "b").Resize(i - p + 1).Merge
        i = i + 1: p = i
      End If
    Next
  End With
  Call doevent(True)
End Sub

Function bsort(arr, first, last, left, right, key, flag)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) <> arr(j + 1, key) Then
        If arr(j, key) < arr(j + 1, key) Xor flag Then
          For k = left To right
            t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
          Next
        End If
      End If
    Next
  Next
End Function

Function rank(arr, first, last, key, col, order As Boolean)
  Dim i As Long, j As Long, m As Long
  m = 1: arr(first, col) = 1
  For i = first + 1 To last
    If order Then
      m = m + 1
    Else
      If arr(i, key) <> arr(i - 1, key) Then m = m + 1
    End If
    If arr(i, key) = arr(i - 1, key) Then
      arr(i, col) = arr(i - 1, col)
    Else
      arr(i, col) = m
    End If
  Next
End Function

Function doevent(flag As Boolean)
  With Application
    .DisplayAlerts = flag
    .ScreenUpdating = flag
  End With
End Function

评分

参与人数 2鲜花 +5 收起 理由
YZC51 + 3 太强大了
zymwhy + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-12-17 08:49 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-17 09:30 | 显示全部楼层
一把小刀闯天下 发表于 2019-12-17 08:40
'这种代码偶尔敲一次还是可以的,练练眼力,,,

Option Explicit

看到这么长的代码,确实让老师付出了,不仅仅是眼力了。这不是一般人能够做出来的,这需要多少年的功底积累!崇拜!

TA的精华主题

TA的得分主题

发表于 2019-12-17 09:31 | 显示全部楼层
PivotTable汇总参考
微信截图_20191217093028.png

生成数据表.rar

17.55 KB, 下载次数: 1

评分

参与人数 1鲜花 +2 收起 理由
zymwhy + 2 感谢帮助

查看全部评分

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

本版积分规则

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2020-4-11 03:40 , Processed in 0.068414 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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