|
本帖最后由 zengbo9999 于 2015-5-21 16:23 编辑
还是说下功能:附件里面的EXCEL有两张表,一个计算表,一个汇总表,现在是在汇总表是双击后,自动计算“计算表”里的工程量并重新输出到汇总表。
其中“计算表”中的名称、型号、数量的列号有可能更改。
我以前只是学过一点C/C++(也只是会点基本的)故对VBA自带函数不熟悉,大概按自己的想法编了一下。
请大神帮忙给优化一下。感谢。
程序代码- Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
- Dim ws1 As Worksheet
- Set ws1 = Sheet2
- Dim inumber As Integer
- Dim iname As Integer
- Dim imodel As Integer
- Dim itotal As Integer
- Dim icompany As Integer
- '先读取数据
- For inumber = 1 To 20
- If ws1.Cells(2, inumber).Value = "项目名称" Then
- iname = inumber
- End If
- If ws1.Cells(2, inumber).Value = "型号" Then
- imodel = inumber
- End If
- If ws1.Cells(2, inumber).Value = "总量" Then
- itotal = inumber
- End If
- If ws1.Cells(2, inumber).Value = "单位" Then
- icompany = inumber
- End If
- Next
- Dim ndate(100, 50, 2) As Variant
- Dim nCompany(100) As Variant
- Dim testmodel As Boolean
- Dim testname As Boolean
- Dim X As Integer
- X = ws1.Range("B65535").End(xlUp).Row
- For a = 3 To X
- If ws1.Cells(a, iname).Value = "" Then
- Exit For
- ElseIf a = 3 Then
- ndate(0, 0, 0) = ws1.Cells(a, iname).Value
- ndate(0, 0, 1) = ws1.Cells(a, imodel).Value
- ndate(0, 0, 2) = ws1.Cells(a, itotal).Value
- nCompany(0) = ws1.Cells(a, icompany).Value
- testname = False
- testmodel = False
- Else 'a不等于3则不是第一次,需要进行比较
- For b = 0 To 100
- If ws1.Cells(a, iname).Value = ndate(b, 0, 0) Then '判断名称在数据中是否存在
- '真值为名称存在
- '存在则判断型号是否存在
- For c = 0 To 50
- If ws1.Cells(a, imodel).Value = ndate(b, c, 1) Then '判断型号在数据中是否存在
- '真值为型号存在
- '型号存在则进行数量相加
- nCompany(b) = ws1.Cells(a, icompany).Value
- ndate(b, c, 0) = ws1.Cells(a, iname).Value
- ndate(b, c, 1) = ws1.Cells(a, imodel).Value
- If ws1.Cells(a, itotal).Text = "#VALUE!" Then
- ndate(b, c, 2) = ndate(b, c, 2) + 0
- Else
- ndate(b, c, 2) = ndate(b, c, 2) + ws1.Cells(a, itotal).Value
- End If
- testmodel = True
- testname = True
- Exit For '退出循环C
- End If
- Next
- If testmodel = True Then '型号判断为真,表示已经存在并记录
- testmodel = False
- Exit For '退出循环B
- Else '型号判断为假表示型号不存在
- For d = 0 To 50
- If ndate(b, d, 1) = "" Then
- If ndate(b, d, 2) = "" Then
- nCompany(b) = ws1.Cells(a, icompany).Value
- ndate(b, d, 0) = ws1.Cells(a, iname).Value
- ndate(b, d, 1) = ws1.Cells(a, imodel).Value
- If ws1.Cells(a, itotal).Text = "#VALUE!" Then
- ndate(b, d, 2) = 0
- Else
- ndate(b, d, 2) = ws1.Cells(a, itotal).Value
- End If
- testname = True
- testmodel = False
- Exit For '退出循环d
- Else
- nCompany(b) = ws1.Cells(a, icompany).Value
- ndate(b, d, 0) = ws1.Cells(a, iname).Value
- ndate(b, d, 1) = ws1.Cells(a, imodel).Value
- If ws1.Cells(a, itotal).Text = "#VALUE!" Then
- ndate(b, d, 2) = ndate(b, d, 2) + 0
- Else
- ndate(b, d, 2) = ndate(b, d, 2) + ws1.Cells(a, itotal).Value
- End If
- testname = True
- testmodel = False
- Exit For '退出循环d
- End If
- End If
- Next d
- End If
- End If
- If testname = True Then '判断此次循环中有无对数据进行更新,为真时表示已更新,退出循环。
- Exit For
- End If
- Next b
- If testname = True Then '名称判断完成,为真值表示已经向数据中增加量
- testname = False
- Else '为假表示没有相同名称
- '增加名称
- For e = 0 To 100
- '判断当前数据中名称多少
- If ndate(e, 0, 0) = "" Then '名称为空时,增加内容
- nCompany(e) = ws1.Cells(a, icompany).Value
- ndate(e, 0, 0) = ws1.Cells(a, iname).Value
- ndate(e, 0, 1) = ws1.Cells(a, imodel).Value
- If ws1.Cells(a, itotal).Text = "#VALUE!" Then
- ndate(e, 0, 2) = 0
- Else
- ndate(e, 0, 2) = ws1.Cells(a, itotal).Value
- End If
- testname = False
- Exit For '退出循环E
- End If
- Next e
- End If
- End If '属于A=3的IF
- Next a
- '以下为数据输出到表格
- Dim ws2 As Worksheet
- Set ws2 = Sheet3
- ws2.Range("3:65535").Delete '清空表格内容
- Dim g As Integer 'G为名称循环
- Dim h As Integer 'H为型号循环
- Dim m As Integer 'M为表格行数记数
- Dim ptestmodel As Boolean
- ptestmodel = False
- m = 0
- For g = 0 To 100
- If ndate(g, 0, 0) = "" Then '数据中名称为空则退出
- Exit For
- Else
- For h = 0 To 50
- If ndate(g, h, 2) = "" Then '数据中数量为空 测试值为真值,表示以无数据
- ptestmodel = True
- Exit For
- Else
- ws2.Cells(m + 3, 1).Value = m + 1
- ws2.Cells(m + 3, 2).Value = ndate(g, h, 0)
- ws2.Cells(m + 3, 3).Value = ndate(g, h, 1)
- ws2.Cells(m + 3, 4).Value = nCompany(g)
- ws2.Cells(m + 3, 5).Value = ndate(g, h, 2)
- ptestmodel = False
- m = m + 1
- End If
- If ptestmodel = True Then '测试值为真值表示没有数据,退出循环
- ptestmodel = False
- Exit For
- End If
- Next h
- End If
- Next g
- With ws2.Range(Cells(3, 1), Cells(m + 3, 6))
- .HorizontalAlignment = xlCenter '水平居中
- .VerticalAlignment = xlCenter '垂直居中
- .RowHeight = 20
- With .Borders
- .LineStyle = xlContinuous '边框线性,细线
- .Weight = xlThin '边框粗细,细
- End With
- With .Font
- .Size = 10
- .Name = "宋体"
- End With
- End With
- <span style="background-color: rgb(255, 255, 255);">End Sub</span>
复制代码
重起炉灶编一个吧,改动反而麻烦。 - Sub 计算()
- arr = Sheets("工程量计算").[a1].CurrentRegion
- Set d = CreateObject("scripting.dictionary")
- ReDim brr(1 To UBound(arr), 1 To 5)
- On Error Resume Next
- For i = 3 To UBound(arr)
- X = arr(i, 2) & arr(i, 3)
- If Len(X) > 0 Then
- If Not d.exists(X) Then
- n = n + 1: d(X) = n
- brr(n, 2) = arr(i, 2)
- brr(n, 3) = arr(i, 3)
- brr(n, 4) = arr(i, 11)
- End If
- brr(d(X), 5) = brr(d(X), 5) + Val(arr(i, 17))
- End If
- Next
- With Sheets("汇总1")
- .[a3:e1000].Clear
- With .[a3].Resize(n, 5)
- .Value = brr
- .HorizontalAlignment = xlCenter '水平居中
- .VerticalAlignment = xlCenter '垂直居中
- .RowHeight = 20
- .Borders.LineStyle = xlContinuous '边框线性,细线
- .Borders.Weight = xlThin '边框粗细,细
- .Font.Size = 10
- .Font.Name = "宋体"
- End With
- .Columns.AutoFit
- .[a3].Resize(n, 5).Sort key1:=.[b3], key2:=.[c3] '按B列,C列排序
- .[a3] = 1: .[a4] = 2 '自动填充序号
- .[a3:a4].AutoFill .[a3].Resize(n, 1)
- End With
- End Sub
复制代码
|
|