Excel精英培训网

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

[已解决]请大神帮忙优化一下

[复制链接]
发表于 2015-5-21 12:00 | 显示全部楼层 |阅读模式
本帖最后由 zengbo9999 于 2015-5-21 16:23 编辑

还是说下功能:附件里面的EXCEL有两张表,一个计算表,一个汇总表,现在是在汇总表是双击后,自动计算“计算表”里的工程量并重新输出到汇总表。
其中“计算表”中的名称、型号、数量的列号有可能更改。
我以前只是学过一点C/C++(也只是会点基本的)故对VBA自带函数不熟悉,大概按自己的想法编了一下。
请大神帮忙给优化一下。感谢。

程序代码
  1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)



  2. Dim ws1 As Worksheet

  3. Set ws1 = Sheet2

  4. Dim inumber As Integer
  5. Dim iname As Integer
  6. Dim imodel As Integer
  7. Dim itotal As Integer
  8. Dim icompany As Integer
  9. '先读取数据
  10. For inumber = 1 To 20
  11. If ws1.Cells(2, inumber).Value = "项目名称" Then
  12. iname = inumber
  13. End If
  14. If ws1.Cells(2, inumber).Value = "型号" Then
  15. imodel = inumber
  16. End If
  17. If ws1.Cells(2, inumber).Value = "总量" Then
  18. itotal = inumber
  19. End If
  20. If ws1.Cells(2, inumber).Value = "单位" Then
  21. icompany = inumber
  22. End If

  23. Next

  24. Dim ndate(100, 50, 2) As Variant
  25. Dim nCompany(100) As Variant
  26. Dim testmodel As Boolean

  27. Dim testname As Boolean

  28. Dim X As Integer

  29. X = ws1.Range("B65535").End(xlUp).Row

  30.     For a = 3 To X
  31.         If ws1.Cells(a, iname).Value = "" Then
  32.             Exit For
  33.         ElseIf a = 3 Then
  34.             ndate(0, 0, 0) = ws1.Cells(a, iname).Value
  35.             ndate(0, 0, 1) = ws1.Cells(a, imodel).Value
  36.             ndate(0, 0, 2) = ws1.Cells(a, itotal).Value
  37.             nCompany(0) = ws1.Cells(a, icompany).Value
  38.             testname = False
  39.             testmodel = False
  40.         Else 'a不等于3则不是第一次,需要进行比较
  41.                 For b = 0 To 100
  42.                     If ws1.Cells(a, iname).Value = ndate(b, 0, 0) Then '判断名称在数据中是否存在
  43.                     '真值为名称存在
  44.                         '存在则判断型号是否存在
  45.                         For c = 0 To 50
  46.                             If ws1.Cells(a, imodel).Value = ndate(b, c, 1) Then '判断型号在数据中是否存在
  47.                             '真值为型号存在
  48.                                 '型号存在则进行数量相加
  49.                                 nCompany(b) = ws1.Cells(a, icompany).Value
  50.                                 ndate(b, c, 0) = ws1.Cells(a, iname).Value
  51.                                 ndate(b, c, 1) = ws1.Cells(a, imodel).Value
  52.                                 If ws1.Cells(a, itotal).Text = "#VALUE!" Then
  53.                                     ndate(b, c, 2) = ndate(b, c, 2) + 0
  54.                                 Else
  55.                                     ndate(b, c, 2) = ndate(b, c, 2) + ws1.Cells(a, itotal).Value
  56.                                 End If
  57.                                 testmodel = True
  58.                                 testname = True
  59.                                 Exit For '退出循环C
  60.                             End If
  61.                         Next
  62.                         If testmodel = True Then '型号判断为真,表示已经存在并记录
  63.                            testmodel = False
  64.                            Exit For '退出循环B
  65.                         Else '型号判断为假表示型号不存在
  66.                             For d = 0 To 50
  67.                                 If ndate(b, d, 1) = "" Then

  68.                                     If ndate(b, d, 2) = "" Then
  69.                                         nCompany(b) = ws1.Cells(a, icompany).Value
  70.                                         ndate(b, d, 0) = ws1.Cells(a, iname).Value
  71.                                         ndate(b, d, 1) = ws1.Cells(a, imodel).Value
  72.                                         If ws1.Cells(a, itotal).Text = "#VALUE!" Then
  73.                                         ndate(b, d, 2) = 0
  74.                                         Else
  75.                                         ndate(b, d, 2) = ws1.Cells(a, itotal).Value
  76.                                         End If
  77.                                         testname = True
  78.                                         testmodel = False
  79.                                         Exit For '退出循环d
  80.                                     Else
  81.                                         nCompany(b) = ws1.Cells(a, icompany).Value
  82.                                         ndate(b, d, 0) = ws1.Cells(a, iname).Value
  83.                                         ndate(b, d, 1) = ws1.Cells(a, imodel).Value
  84.                                         If ws1.Cells(a, itotal).Text = "#VALUE!" Then
  85.                                         ndate(b, d, 2) = ndate(b, d, 2) + 0
  86.                                         Else
  87.                                         ndate(b, d, 2) = ndate(b, d, 2) + ws1.Cells(a, itotal).Value
  88.                                         End If
  89.                                         testname = True
  90.                                         testmodel = False
  91.                                         Exit For '退出循环d
  92.                                     End If
  93.                                 End If
  94.                             Next d

  95.                         End If
  96.                     End If
  97.                     If testname = True Then '判断此次循环中有无对数据进行更新,为真时表示已更新,退出循环。
  98.                         Exit For
  99.                     End If
  100.                 Next b

  101.                If testname = True Then '名称判断完成,为真值表示已经向数据中增加量

  102.                testname = False

  103.                Else '为假表示没有相同名称

  104.                '增加名称
  105.                 For e = 0 To 100
  106.                     '判断当前数据中名称多少
  107.                     If ndate(e, 0, 0) = "" Then '名称为空时,增加内容
  108.                         nCompany(e) = ws1.Cells(a, icompany).Value
  109.                         ndate(e, 0, 0) = ws1.Cells(a, iname).Value
  110.                         ndate(e, 0, 1) = ws1.Cells(a, imodel).Value
  111.                         If ws1.Cells(a, itotal).Text = "#VALUE!" Then
  112.                         ndate(e, 0, 2) = 0
  113.                         Else
  114.                         ndate(e, 0, 2) = ws1.Cells(a, itotal).Value
  115.                         End If
  116.                         testname = False
  117.                         Exit For '退出循环E
  118.                     End If

  119.                 Next e

  120.                 End If

  121.         End If '属于A=3的IF
  122.     Next a
  123. '以下为数据输出到表格
  124. Dim ws2 As Worksheet
  125. Set ws2 = Sheet3

  126. ws2.Range("3:65535").Delete '清空表格内容
  127. Dim g As Integer 'G为名称循环
  128. Dim h As Integer 'H为型号循环
  129. Dim m As Integer 'M为表格行数记数
  130. Dim ptestmodel As Boolean
  131. ptestmodel = False
  132. m = 0
  133. For g = 0 To 100
  134.     If ndate(g, 0, 0) = "" Then '数据中名称为空则退出
  135.        Exit For
  136.     Else

  137.         For h = 0 To 50

  138.             If ndate(g, h, 2) = "" Then '数据中数量为空 测试值为真值,表示以无数据

  139.                 ptestmodel = True
  140.                 Exit For
  141.             Else
  142.                 ws2.Cells(m + 3, 1).Value = m + 1
  143.                 ws2.Cells(m + 3, 2).Value = ndate(g, h, 0)
  144.                 ws2.Cells(m + 3, 3).Value = ndate(g, h, 1)
  145.                 ws2.Cells(m + 3, 4).Value = nCompany(g)
  146.                 ws2.Cells(m + 3, 5).Value = ndate(g, h, 2)
  147.                 ptestmodel = False
  148.                 m = m + 1
  149.             End If
  150.             If ptestmodel = True Then '测试值为真值表示没有数据,退出循环
  151.                 ptestmodel = False
  152.                 Exit For
  153.             End If

  154.         Next h
  155.     End If
  156. Next g

  157. With ws2.Range(Cells(3, 1), Cells(m + 3, 6))
  158.         .HorizontalAlignment = xlCenter   '水平居中
  159.         .VerticalAlignment = xlCenter   '垂直居中
  160.         .RowHeight = 20
  161.         With .Borders
  162.             .LineStyle = xlContinuous  '边框线性,细线
  163.             .Weight = xlThin   '边框粗细,细
  164.         End With
  165.         With .Font
  166.         .Size = 10
  167.         .Name = "宋体"
  168.         End With

  169. End With

  170. <span style="background-color: rgb(255, 255, 255);">End Sub</span>

复制代码
最佳答案
2015-5-21 16:22
重起炉灶编一个吧,改动反而麻烦。
  1. Sub 计算()
  2.     arr = Sheets("工程量计算").[a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     ReDim brr(1 To UBound(arr), 1 To 5)
  5.     On Error Resume Next
  6.     For i = 3 To UBound(arr)
  7.         X = arr(i, 2) & arr(i, 3)
  8.         If Len(X) > 0 Then
  9.             If Not d.exists(X) Then
  10.                 n = n + 1: d(X) = n
  11.                 brr(n, 2) = arr(i, 2)
  12.                 brr(n, 3) = arr(i, 3)
  13.                 brr(n, 4) = arr(i, 11)
  14.             End If
  15.             brr(d(X), 5) = brr(d(X), 5) + Val(arr(i, 17))
  16.         End If
  17.     Next
  18.     With Sheets("汇总1")
  19.         .[a3:e1000].Clear
  20.         With .[a3].Resize(n, 5)
  21.             .Value = brr
  22.              .HorizontalAlignment = xlCenter   '水平居中
  23.             .VerticalAlignment = xlCenter   '垂直居中
  24.             .RowHeight = 20
  25.              .Borders.LineStyle = xlContinuous  '边框线性,细线
  26.             .Borders.Weight = xlThin   '边框粗细,细
  27.             .Font.Size = 10
  28.             .Font.Name = "宋体"
  29.         End With
  30.         .Columns.AutoFit
  31.         .[a3].Resize(n, 5).Sort key1:=.[b3], key2:=.[c3]    '按B列,C列排序
  32.         .[a3] = 1: .[a4] = 2       '自动填充序号
  33.         .[a3:a4].AutoFill .[a3].Resize(n, 1)
  34.     End With
  35. End Sub
复制代码

计算.rar

56.8 KB, 下载次数: 3

发表于 2015-5-21 16:22 | 显示全部楼层    本楼为最佳答案   
重起炉灶编一个吧,改动反而麻烦。
  1. Sub 计算()
  2.     arr = Sheets("工程量计算").[a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     ReDim brr(1 To UBound(arr), 1 To 5)
  5.     On Error Resume Next
  6.     For i = 3 To UBound(arr)
  7.         X = arr(i, 2) & arr(i, 3)
  8.         If Len(X) > 0 Then
  9.             If Not d.exists(X) Then
  10.                 n = n + 1: d(X) = n
  11.                 brr(n, 2) = arr(i, 2)
  12.                 brr(n, 3) = arr(i, 3)
  13.                 brr(n, 4) = arr(i, 11)
  14.             End If
  15.             brr(d(X), 5) = brr(d(X), 5) + Val(arr(i, 17))
  16.         End If
  17.     Next
  18.     With Sheets("汇总1")
  19.         .[a3:e1000].Clear
  20.         With .[a3].Resize(n, 5)
  21.             .Value = brr
  22.              .HorizontalAlignment = xlCenter   '水平居中
  23.             .VerticalAlignment = xlCenter   '垂直居中
  24.             .RowHeight = 20
  25.              .Borders.LineStyle = xlContinuous  '边框线性,细线
  26.             .Borders.Weight = xlThin   '边框粗细,细
  27.             .Font.Size = 10
  28.             .Font.Name = "宋体"
  29.         End With
  30.         .Columns.AutoFit
  31.         .[a3].Resize(n, 5).Sort key1:=.[b3], key2:=.[c3]    '按B列,C列排序
  32.         .[a3] = 1: .[a4] = 2       '自动填充序号
  33.         .[a3:a4].AutoFill .[a3].Resize(n, 1)
  34.     End With
  35. End Sub
复制代码

22#楼户内电气计算.rar

60.66 KB, 下载次数: 5

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 21:24 , Processed in 0.584389 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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