Option Explicit
Sub TEST()
Dim Brr, Crr, Z, i&, j%, R&, C, Ta, jj#, Ce%, xA As Range
Set Z = CreateObject("Scripting.Dictionary")
Set xA = Range([A1], ActiveSheet.UsedRange)
Brr = Union(xA, xA.Offset(, 1))
Ta = [{"項目","今年起點","目前進度","達成率"}]
Ce = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To UBound(Ta)
C = Application.Match(Ta(i), [1:1], 0)
If IsError(C) Then MsgBox "沒有 " & Ta(i) & " 標題": Exit Sub Else Z(Ta(i) & "") = C
Next
For j = Z.Items()(3) To Ce + 1
If Val(Brr(1, j + 1)) = 0 Then Exit For
For jj = Val(Brr(1, j)) To Val(Brr(1, j + 1)) Step 0.01: Z(Format(jj, "000.00")) = j: Next
Next
ReDim Crr(1 To UBound(Brr), 1 To 100)
For i = 2 To Cells(Rows.Count, Z("項目")).End(3).Row
If Brr(i, Z("項目")) = "" Then Exit For Else R = R + 1
For j = 1 To Ce - Z("達成率")
Crr(R, j) = Round((1 + (Brr(1, Z("達成率") + j) / 100)) * Brr(i, Z("今年起點")), 2)
Next
Rows(i).Interior.ColorIndex = xlNone
jj = Round((Brr(i, Z("目前進度")) - Brr(i, Z("今年起點"))) / Brr(i, Z("今年起點")) * 100, 2)
Brr(R, 1) = jj: If jj < 0 Then Cells(i, Z("達成率")).Interior.ColorIndex = 3: GoTo i01
C = Z(Format(jj, "000.00")): Cells(i, C).Interior.ColorIndex = 6
If jj < 10 Then Cells(i, Z("達成率")).Interior.ColorIndex = 43
i01: Next
Cells(2, Z("達成率") + 1).Resize(R, Ce - Z("達成率")) = Crr
Cells(2, Z("達成率")).Resize(R, 1) = Brr
End Sub作者: hcm19522 時間: 2023-12-15 10:49
Option Explicit
Sub TEST_1()
Dim Brr, Crr, Z, i&, j%, R&, C, Ta, jj#, Ce%, xA As Range, A
Set Z = CreateObject("Scripting.Dictionary")
Set xA = Range([A1], ActiveSheet.UsedRange)
Brr = Union(xA, xA.Offset(, 1))
Ta = [{"項目","今年起點","目前進度","達成率"}]
Ce = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To UBound(Ta)
C = Application.Match(Ta(i), [1:1], 0)
If IsError(C) Then MsgBox "沒有 " & Ta(i) & " 標題": Exit Sub Else Ta(i) = C
Next
For j = Ta(4) To Ce + 1
If Val(Brr(1, j + 1)) = 0 Then Exit For
Z("(" & Val(Brr(1, j)) & "-|)*(" & Val(Brr(1, j + 1)) & "-|)") = j
Next
ReDim Crr(1 To UBound(Brr), 1 To 100)
For i = 2 To Cells(Rows.Count, Ta(1)).End(3).Row
If Brr(i, Ta(1)) = "" Then Exit For Else R = R + 1
For j = 1 To Ce - Ta(4)
Crr(R, j) = Round((1 + (Brr(1, Ta(4) + j) / 100)) * Brr(i, Ta(2)), 2)
Next
Rows(i).Interior.ColorIndex = xlNone
jj = Round((Brr(i, Ta(3)) - Brr(i, Ta(2))) / Brr(i, Ta(2)) * 100, 2)
Brr(R, 1) = jj: If jj < 0 Then Cells(i, Ta(4)).Interior.ColorIndex = 3: GoTo i01
For Each A In Z.KEYS
C = Replace(A, "|", jj)
If Evaluate(C) <= 0 Then Cells(i, Z(A) - (Evaluate(C) = 0)).Interior.ColorIndex = 6: Exit For
A01: Next
If jj < 10 Then Cells(i, Ta(4)).Interior.ColorIndex = 42
i01: Next
Cells(2, Ta(4) + 1).Resize(R, Ce - Ta(4)) = Crr
Cells(2, Ta(4)).Resize(R, 1) = Brr
End Sub
'============================================
以下是沒有用字典的陣列方案: (做了註解方便用手機 查看做複習)
Option Explicit
Sub TEST_2()
Dim Brr, Crr, i&, j%, R&, C, Ta, jj#, Ce%, xA As Range, A#
'↑宣告變數
Set xA = Range([A1], ActiveSheet.UsedRange)
'↑令xA變數是有使用儲存格方正區域
Brr = Union(xA, xA.Offset(, 1))
'↑令Brr變數是帶入(xA範圍儲存格往右擴增1欄)儲存格值的二維陣列
Ta = [{"項目","今年起點","目前進度","達成率"}]
'↑令Ta變數是索引號1~4的四組字串一維陣列
Ce = xA(1, Columns.Count).End(xlToLeft).Column
'↑令Ce變數是第1列最右邊有內容儲存格欄位數
For i = 1 To UBound(Ta)
'↑設順迴圈!i從1 到Ta陣列最大索引號
C = Application.Match(Ta(i), [1:1], 0)
'↑令C變數是以執行儲存格函數 Match() 回傳值
If IsError(C) Then MsgBox "沒有 " & Ta(i) & " 標題": Exit Sub Else Ta(i) = C
'↑如果找不到標題就跳出提視窗~~,結束程式執行,否則令Ta陣列值變成C變數(欄位數)
Next
ReDim Crr(1 To UBound(Brr), 1 To 100)
'↑宣告Crr變數是二維空陣列,範圍大小須比需求大或剛好
For i = 2 To xA(Rows.Count, Ta(1)).End(3).Row
'↑設順迴圈!i從2 到 項目欄下尋最後個有內容的儲存格列號
If Brr(i, Ta(1)) = "" Then Exit For Else R = R + 1
'↑如果項目欄迴圈列陣列值是空的就結束迴圈,否則令R變數累加1
For j = 1 To Ce - Ta(4)
'↑設順迴圈!將標題各段落達成率%+1乘上 今年起點,乘積取小數2位,寫入Crr陣列中
Crr(R, j) = Round((1 + (Brr(1, Ta(4) + j) / 100)) * Brr(i, Ta(2)), 2)
Next
Rows(i).Interior.ColorIndex = xlNone
'↑令迴圈列底色為無底色
jj = Round((Brr(i, Ta(3)) - Brr(i, Ta(2))) / Brr(i, Ta(2)) * 100, 2)
'↑令jj變數是實際達成率
Brr(R, 1) = jj: If jj < 0 Then xA(i, Ta(4)).Interior.ColorIndex = 3: GoTo i01
'↑令實際達成率寫入Brr陣列最左上角,往下繼續寫入
'如果實際達成率<0,就令迴圈列達成率欄儲存格底色是 紅色,之後跳到標示i01位置繼續執行
For j = Ta(4) To UBound(Brr, 2)
'↑設順迴圈判定哪一欄儲存格底色須變為黃色
If Val(Brr(1, j + 1)) = 0 Then Exit For
'↑如果跑到最後欄就結束迴圈
A = (Val(Brr(1, j)) - jj) * (Val(Brr(1, j + 1)) - jj)
'↑令A變數是以(j欄段落達成率-實際達成率)*(j+1欄段落達成率-實際達成率)乘積
If A <= 0 Then
'↑如果A變數是負數或 0
xA(i, j - (A = 0)).Interior.ColorIndex = 6
'↑如果A是0,右邊格黃底,否則就當格黃底
Exit For
'↑令跳出迴圈
End If
Next
If jj < 10 Then xA(i, Ta(4)).Interior.ColorIndex = 41
'↑如果如果實際達成率小於10%,就令i迴圈列達成率欄儲存格 藍底
i01: Next
xA(2, Ta(4) + 1).Resize(R, Ce - Ta(4)) = Crr
'↑令段落達成率寫入儲存格
xA(2, Ta(4)).Resize(R, 1) = Brr
'↑令實際達成率寫入儲存格
End Sub作者: dou10801 時間: 2023-12-15 13:51
