工作表模組:
Option Explicit 'H4寫入選取A欄的儲存格
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
Dim T$
If .Columns.Count <> 1 Or .Column <> 1 Or .Row = 1 Then Exit Sub
T = .Address(0, 1): [H4] = T
End With
End Sub
'========================================
Sub TEST()
Dim Brr, Crr, V, Y, A, R&, i&, j%, M&, T$, Tr$, V1&, V2&
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([D1], [A65536].End(3))
For i = 2 To UBound(Brr)
For j = 3 To 4
Y(Brr(1, j)) = j
T = Brr(1, j) & "|" & Brr(i, 1): Tr = Brr(1, j) & "|" & i
Y(T) = i: Y(T & "|" & "Sum") = Y(T & "|" & "Sum") + Brr(i, j)
Y(Tr) = i: Y(Tr & "|" & "Sum") = Y(Tr & "|" & "Sum") + Brr(i, j)
Next
Next
[I2:I65536].ClearContents
Crr = Range([I1], [H65536].End(3))
For i = 2 To UBound(Crr)
T = Trim(Crr(i, 1)): If T = "" Then GoTo i01
A = Split(Replace(Replace(Crr(i, 1), "$A", ""), ":", "~"), ",")
If A(0) = "" Then GoTo i01
For Each V In A
V1 = Y(Crr(1, 2) & "|" & Split(V, "~")(0))
V2 = Y(Crr(1, 2) & "|" & StrReverse(Split(StrReverse(V), "~")(0)))
If InStr(V, "~") Then
If V1 * V2 = 0 Then Crr(i, 2) = "": GoTo v01
If V1 > V2 Then M = V2: V2 = V1: V1 = M
For R = V1 To V2: Crr(i, 2) = Crr(i, 2) + Brr(R, Y(Crr(1, 2))): Next
ElseIf Y(Crr(1, 2) & "|" & V & "|" & "Sum") <> "" Then
Crr(i, 2) = Crr(i, 2) + Y(Crr(1, 2) & "|" & V & "|" & "Sum")
v01: End If
Next
i01: Next
[H1].Resize(UBound(Crr), 2) = Crr
Set Y = Nothing: Erase Brr, Crr, A
End Sub作者: Andy2483 時間: 2023-6-5 12:29
Option Explicit 'H4寫入選取A欄的儲存格
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
Dim T$, xR As Range
Set xR = Range([A2], [A65536].End(3))
If .Columns.Count <> 1 Or .Column <> 1 Then Exit Sub
If Intersect(xR, Selection.Cells) Is Nothing Then Exit Sub
T = Intersect(xR, Selection.Cells).Address(0, 1)
[H4] = T
End With
End Sub作者: Andy2483 時間: 2023-6-5 14:06
Option Explicit
Function SumText(xC As String, xY As String)
Dim Brr, Crr, V, Y, A, R&, i&, j%, M&, T$, Tr$, V1&, V2&, Z&
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([D1], [A65536].End(3))
For i = 2 To UBound(Brr)
For j = 3 To 4
Y(Brr(1, j)) = j
T = Brr(1, j) & "|" & Brr(i, 1): Tr = Brr(1, j) & "|" & i
Y(T) = i: Y(T & "|" & "Sum") = Y(T & "|" & "Sum") + Brr(i, j)
Y(Tr) = i: Y(Tr & "|" & "Sum") = Y(Tr & "|" & "Sum") + Brr(i, j)
Next
Next
T = Trim(xC): If T = "" Then GoTo 102
A = Split(Replace(Replace(xC, "$A", ""), ":", "~"), ",")
If A(0) = "" Then Z = 0: GoTo 102
For Each V In A
V1 = Y(xY & "|" & Split(V, "~")(0))
V2 = Y(xY & "|" & StrReverse(Split(StrReverse(V), "~")(0)))
If InStr(V, "~") Then
If V1 * V2 = 0 Then Z = 0: GoTo 102
If V1 > V2 Then M = V2: V2 = V1: V1 = M
For R = V1 To V2: Z = Z + Brr(R, Y(xY)): Next
ElseIf Y(xY & "|" & V & "|" & "Sum") = "" Then
Z = 0: GoTo 102
Else
Z = Z + Y(xY & "|" & V & "|" & "Sum")
End If
v01: Next
102: If Z <> 0 Then SumText = Z Else SumText = ""
End Function作者: gaishutsusuru 時間: 2023-6-5 21:17
Option Explicit'工作表模組
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'↑當工作表上的選取範圍變更時會發生此事件
With Target
'↑以下是關於觸發的程序
Dim T$, xR As Range
'↑宣告變數
Set xR = Range([A2], [A65536].End(3))
'↑令xR變數是[A2]到A欄最後一個有內容儲存格,這範圍儲存格
If .Columns.Count <> 1 Or .Column <> 1 Then Exit Sub
'↑如果選取觸發的欄數不是1欄,或欄號不是1,就結束執行
If Intersect(xR, Selection.Cells) Is Nothing Then Exit Sub
'↑如果xR變數與選取觸發的儲存格沒交集,就結束執行
T = Intersect(xR, Selection.Cells).Address(0, 1)
'↑令T變數是 xR變數與選取觸發的儲存格交集儲存格位址(欄號有$)
[H4] = T
'↑令[H4]儲存格值是 T變數
End With
End Sub
Option Explicit'一般模組
Function SumText(xC As String, xY As String)
'↑自訂函數SumText(),宣告變數xC,xY都是字串變數
Dim Brr, Crr, V, Y, A, R&, i&, V1&, V2&, Z&, M&, j%, T$, Tr$
'↑宣告變數(Brr,Crr,V,Y,A)是通用型變數,(R,i,V1,V2,Z,M)是長整數,
'j是短整數,(T,Tr)是字串變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是 字典
Brr = Range([D1], [A65536].End(3))
'↑令Brr變數是 二維陣列,以A~D欄儲存格值帶入
For i = 2 To UBound(Brr)
'↑設順迴圈
For j = 3 To 4
'↑設順迴圈
Y(Brr(1, j)) = j
'↑令第1列j迴圈欄Brr陣列值當key,item是j迴圈數(記年分的陣列欄號)
T = Brr(1, j) & "|" & Brr(i, 1): Tr = Brr(1, j) & "|" & i
'↑令T變數是 第1列j迴圈欄Brr陣列值連接"|",再連接i迴圈第1欄Brr陣列值,
'令Tr變數是 第1列j迴圈欄Brr陣列值連接"|",再連接i迴圈數
Y(T) = i: Y(T & "|Sum") = Y(T & "|Sum") + Brr(i, j)
'↑令T變數是key,item是i變數,納入Y字典中
'↑令以T變數連接"|Sum"組成新字串當key,item是
'是累加i迴圈列j迴圈欄Brr陣列值
Y(Tr) = i: Y(Tr & "|Sum") = Y(Tr & "|Sum") + Brr(i, j)
'↑令Tr變數當key,item是i變數,納入Y字典中,
'↑令以Tr變數連接"|Sum"組成新字串當key,item是
'是累加i迴圈列j迴圈欄Brr陣列值
Next
Next
T = Trim(xC): If T = "" Then GoTo 102
'↑令T變數是 xC變數去除前後空白字元後的新字串,
'如果T變數是 空字元?就跳到標示102位置繼續執行
A = Split(Replace(Replace(xC, "$A", ""), ":", "~"), ",")
'↑令A變數是xC變數字串被分割成的一維陣列
'被xC變數被分割前先做2次的字元置換,"$A"換成 "", ":"換成 "~"
'最後以逗號分割成一維陣列
If A(0) = "" Then Z = 0: GoTo 102
'↑如果0索引號A陣列值是 空字元?就令Z變數是0,跳到標示102位置繼續執行
For Each V In A
'↑設逐項迴圈!令V變數是 A陣列裡的一陣列值
V1 = Y(xY & "|" & Split(V, "~")(0))
'↑令V1變數是xY變數連接"|",
'再連接(V變數以"~"分割後的0索引號陣列值)所組成的新字串查,
'查Y字典回傳item值
V2 = Y(xY & "|" & StrReverse(Split(StrReverse(V), "~")(0)))
'↑令以V2變數是xY變數連接"|",再連接(V變數字元順序顛倒後,
'以"~"分割後的0索引號陣列值做字元順序顛倒回來,
'以上組成的新字串查Y字典回傳item值
If InStr(V, "~") Then
'↑如果V變數裡有包含"~" ?
If V1 * V2 = 0 Then Z = 0: GoTo 102
'↑如果V1變數與V2變數的乘積是 0,
'就令Z變數是0 , 跳到標示102位置繼續執行
If V1 > V2 Then M = V2: V2 = V1: V1 = M
'↑如果V1變數大於V2變數?就令M變數協助讓V1.V2值互換
For R = V1 To V2: Z = Z + Brr(R, Y(xY)): Next
'↑設順迴圈!從V1變數到V2變數,令Z變數是 Brr陣列值,
'(R是指Brr陣列列號,Y(xY)是指$I$1儲存格值查Y字典記的欄號)
ElseIf Y(xY & "|" & V & "|Sum") = "" Then
'↑否則如果以組合字串查Y字典裡item是空字元?
Z = 0: GoTo 102
'就令Z變數是0 , 跳到標示102位置繼續執行
Else
Z = Z + Y(xY & "|" & V & "|Sum")
'↑否則就令Z變數累加 組合字串查Y字典裡item值
End If
Next
102: If Z <> 0 Then SumText = Z Else SumText = ""
'↑如果Z變數不是0,就令SumText函數回傳Z變數(長整數變數),
'否則就回傳空字元
End Function作者: 星空乂羽翼 時間: 2023-6-8 11:24
