- 帖子
- 145
- 主題
- 42
- 精華
- 0
- 積分
- 193
- 點名
- 0
- 作業系統
- Windows7
- 軟體版本
- Office2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2010-11-25
- 最後登錄
- 2024-10-10
|
2#
發表於 2023-10-4 22:32
| 只看該作者
感謝Andy2483在一般區的協助，已成功解決給大家參考~
將說明標題修改
 公式簡化 20231002-4.rar (114.31 KB)
Sub TEST()
Dim Brr, Crr, Z, i&, j%, V%, V7%
Set Z = CreateObject("Scripting.Dictionary")
With Sheets("說明"): Brr = Range(.Cells(.UsedRange.Rows.Count, "A"), .[IV1].End(xlToLeft)): End With
For j = 1 To UBound(Brr, 2)
If Left(Trim(Brr(1, j)), 6) <> "" Then Z(Left(Trim(Brr(1, j)), 6)) = j
Next
Crr = Range([WIP!O1], [WIP!A65536].End(3))
For i = 2 To UBound(Crr)
V = Val(Crr(i, 15)): V7 = Val(Crr(i, 7)): Crr(i - 1, 1) = ""
If Z.Exists(Left(Trim(Crr(i, 1)), 6)) <> Empty Then
Crr(i - 1, 1) = Round(Brr(V7 + 2, Z(Left(Trim(Crr(i, 1)), 6))) * V, 0)
ElseIf Right(Left(Crr(i, 1), 7), 1) = "W" Then
Crr(i - 1, 1) = Round(Brr(V7 + 2, Z("W")) * V, 0)
Else
Crr(i - 1, 1) = Round(Brr(V7 + 2, Z(Left(Crr(i, 2), 1))) * V, 0)
End If
Next
[WIP!D2].Resize(UBound(Crr) - 1, 1) = Crr
Set Z = Nothing: Erase Brr, Crr
End Sub |
|
