|
根据批号查询 CF表中的成分 支数 捻度 计划车速
显示在C/D/E/F列中
再计算折产 折产公式(支数×捻度×混产÷52÷680)(显示在M列,R列,V列,AC列)
还有单本混 单折52 单折680(逻辑 根据批号查找CF列中L列,第一位是1时AT列显示三个班的混产合计,AU列显示三个班的折52产量合计(折52:混×支数÷52), AV列显示三个班的折680产量合计)
因为运行错误, 请大神看以下代码如何改正及优化
Sub atest()
Application.ScreenUpdating = False: Application.Calculation = xlManual ' 手工计算
Worksheets("产量").Activate
Dim T1 As Date: T1 = Timer ' 记时
Dim arr, brr, crr(), d As Object, i&, R
Set d = CreateObject("scripting.dictionary")
arr = Sheets("CF").Range("e2").CurrentRegion ' 将数据库表赋值于数组arr
For i = 2 To UBound(arr)
d("" & arr(i, 1)) = i ' 将批号(工艺)加入字典
Next
With ActiveSheet
brr = .Range("b4:F454").Value ' 将区域加入字典brr
ReDim crr(1 To UBound(brr), 1 To 5)
For i = 1 To UBound(brr)
R = d("" & brr(i, 1)) ' 循环获取批号在字典中的行号
If R <> "" Then
crr(i, 2) = arr(R, 6) ' 将arr数组中符合条件的记录赋值数组crr,对应列号
crr(i, 3) = arr(R, 3)
crr(i, 4) = arr(R, 5)
crr(i, 5) = arr(R, 9)
End If
crr(i, 1) = brr(i, 1)
Next
.[b4].Resize(i - 2, 5) = crr ' 一次性赋值
' *****************
Dim mRow&, AR(), BR(), CR(), DR(), j As Long
mRow = .Cells(.Rows.Count, 1).End(3).Row ' 获取A列最大行号
arr = .Range("A4:BF" & mRow).Value ' 将数据区域赋值于数组arr
' 重定义数组大小,因为你表中有公式,区域不连续,所以,只能定义几个数组分别写入,从而达到保留公式的目的
ReDim AR(1 To UBound(arr), 1 To 1)
ReDim BR(1 To UBound(arr), 1 To 1)
ReDim CR(1 To UBound(arr), 1 To 1)
ReDim DR(1 To UBound(arr), 1 To 1)
ReDim ER(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr) ' 根据条件,循环赋值
If Val(arr(i, 11)) = 0 Or Val(arr(i, 4)) = 0 Or Val(arr(i, 5)) = 0 Then AR(i, 1) = Empty Else AR(i, 1) = VBA.Round(Val(arr(i, 11)) * Val(arr(i, 4)) * Val(arr(i, 5)) / 52 / 680, 1)
If Val(arr(i, 16)) = 0 Or Val(arr(i, 4)) = 0 Or Val(arr(i, 5)) = 0 Then BR(i, 1) = Empty Else BR(i, 1) = VBA.Round(Val(arr(i, 16)) * Val(arr(i, 4)) * Val(arr(i, 5)) / 52 / 680, 1)
If Val(arr(i, 21)) = 0 Or Val(arr(i, 4)) = 0 Or Val(arr(i, 5)) = 0 Then CR(i, 1) = Empty Else CR(i, 1) = VBA.Round(Val(arr(i, 21)) * Val(arr(i, 4)) * Val(arr(i, 5)) / 52 / 680, 1)
If Val(arr(i, 13)) = 0 And Val(arr(i, 18)) = 0 And Val(arr(i, 23)) = 0 Then DR(i, 1) = Empty Else DR(i, 1) = VBA.Round(Val(arr(i, 13)) + Val(arr(i, 18)) + Val(arr(i, 23)), 1)
If Left(Application.Worksheetsfunction.VLookup(Cells(i, 2), Worksheets("CF").Range("$E2:$M10080"), 8, 0), 1) = "1" Then
ER(i, 1) = Val(arr(i, 27))
End If
Next
' 将赋值后的数组写入单元格
.Range("AT4").Resize(UBound(arr), 1).Value = ER
.Range("M4").Resize(UBound(arr), 1).Value = AR
.Range("R4").Resize(UBound(arr), 1).Value = BR
.Range("W4").Resize(UBound(arr), 1).Value = CR
.Range("AC4").Resize(UBound(arr), 1).Value = DR
' --------------以下为重新写入单元格公式
' *** 一组合计
.Range("K144").FormulaR1C1 = "=SUM(R[-140]C:R[-1]C)"
.Range("K144").Copy
.Range("L144:BF144").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' *** 二组合计
.Range("K285").FormulaR1C1 = "=SUM(R[-140]C:R[-7]C)"
.Range("K285").Copy
.Range("L285:BF285").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' *** 三组合计
.Range("K370").FormulaR1C1 = "=SUM(R[-63]C:R[-42]C)"
.Range("K370").Copy
.Range("L370:BF370").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' *** 四组合计
.Range("K455").FormulaR1C1 = "=SUM(R[-84]C:R[-1]C)"
.Range("K455").Copy
.Range("L455:BF455").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' *** 总计
.Range("K456").FormulaR1C1 = "=SUM(R[-312]C,R[-171]C,R[-86]C,R[-1]C)"
.Range("K456").Copy
.Range("L456:BF456").PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False: Set d = Nothing
MsgBox "数据更新已完成,用时约: " & Format(Timer - T1, "0.00") & " 秒. ", 64 + 0, "提醒"
With .Range("b4:B454")
.EntireRow.Hidden = False ' 显示所有行
.SpecialCells(xlCellTypeBlanks).Rows.Hidden = True ' 隐藏区域内的空行
End With
.Range("b4").Select
End With
Application.ScreenUpdating = True: Application.Calculation = xlAutomatic ' 自动计算
End Sub
|
|