麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Sub 計算套裝級別()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row
Dim i As Long
Dim score As String
Dim skip As Boolean
Dim combinations As Variant
Dim scores As Variant
' 定義套裝和級別
combinations = Array("良優優良", "優良良優", "良優優優", "優良良良", "良優良", "優良優", "優優", "良良")
scores = Array("2", "2", "3", "3", "3", "3", "3", "3")
For i = 2 To lastRow
If Not skip Then ' 如果skip為False，則執行此代碼塊
Dim j As Long
'檢查當前的字符序列（combo）是否與combinations數組中的任何一個元素匹配。
'如果匹配，則根據對應的scores數組中的級別來更新score變量，並在工作表的"O"列中顯示該級別。
For j = LBound(combinations) To UBound(combinations)
Dim combo As String
combo = ""
On Error Resume Next
combo = ws.Cells(i, "L").Value & ws.Cells(i + 1, "L").Value & ws.Cells(i + 2, "L").Value & ws.Cells(i + 3, "L").Value
On Error GoTo 0
'這段代碼的目的是在找到匹配的套裝時計算並顯示相應的級別。
combo = Left(combo, Len(combinations(j))) ' 取組合的長度,這行代碼將combo字符串的左側部分（長度為combinations(j)的長度）賦值給combo。
' 這是為了確保combo的長度與當前的套裝combinations(j)的長度相同，以便進行比較。
If combo = combinations(j) And ws.Cells(i, "L").Value <> ws.Cells(i - 1, "L").Value Then '檢查combo是否等於當前的套裝combinations(j)，並且當前行的"L"列的值與前一行的"L"列的值不同
score = scores(j)
ws.Cells(i + Len(combinations(j)) - 1, "O").Value = score ' 在O列的相對行數顯示級別
If score = 2 Or score = 3 Then
skip = True ' 如果skip為True，則執行此代碼塊
End If
Exit For
End If
Next j
Else
'以下這段代碼的目的是在遇到新的字符序列開始時（即當前行的"L"列的值與前一行的"L"列的值不同，並且當前行的"L"列的值等於當前套裝的第一個字符時），停止跳過迭代。
'如果skip為True，則會跳過當前的迭代，直到遇到新的字符序列開始。這樣可以防止在同一個字符序列中多次計算級別。
If ws.Cells(i, "L").Value <> ws.Cells(i - 1, "L").Value And ws.Cells(i, "L").Value = Left(combinations(j), 1) Then
skip = False
End If
End If
Next i
End Sub

複製代碼

Sub Test_A1()
Dim Arr, A, Brr, xD, i&, j&, T$, Tr, R, lastChar$
Set xD = CreateObject("Scripting.Dictionary") '創建一個字典對象
'遍歷一個數組，並將每個元素按"\"分割，然後將分割後的第二部分作為鍵，第一部分作為值存入字典
For Each A In Array("1^12\優優良", "2^10\良良優", "3^3\優優優", "4^3\良良良", _
"5^3\優良", "6^3\良優", "7^-3\優優", "8^-10\良良")
Tr = Split(A, "\")
xD(Tr(1)) = Tr(0)
Next A
'讀取Excel工作表中的一個範圍到Arr數組，然後根據Arr的大小重新定義Brr數組
Arr = Range([L1], [L65536].End(xlUp)(5))
ReDim Brr(1 To UBound(Arr), 0)
'關閉屏幕更新，以提高代碼執行速度
Application.ScreenUpdating = False
'遍歷Arr數組，並根據字典中的條目對Excel工作表中的某些單元格進行格式化
For i = 2 To UBound(Arr) - 4
T = Arr(i, 1)
If T <> Arr(i - 1, 1) Then
For j = i + 1 To i + 2
T = T & Arr(j, 1)
R = xD(T)
If R <> "" Then
Tr = Split(R, "^")
lastChar = Right(Tr(1), 1)
If Arr(j + 1, 1) <> lastChar Then
With Range("L" & i & ":L" & j)
.BorderAround 1
.Interior.ColorIndex = Cells(Tr(0) + 2, 1).Interior.ColorIndex
End With
Brr(j - 1, 0) = Tr(1): i = j: Exit For
End If
End If
Next j
End If
Next i
'將Brr數組的內容寫入Excel工作表的一個範圍
[o2].Resize(UBound(Brr)) = Brr
End Sub

複製代碼