重寫//
Sub 載入()
Dim Arr, Brr, xD, T$, R&, N&, i&, j%, S As Worksheet
ReDim Brr(1 To 30000, 1 To 14)
Call 清除
Set xD = CreateObject("Scripting.Dictionary")
For Each S In Sheets
If S.Name = "匯總" Then GoTo s01
Arr = Range(S.[n1], S.[a65536].End(3))
For i = 5 To UBound(Arr)
T = Arr(i, 1): R = xD(T)
If R = 0 Then
N = N + 1: R = N: xD(T) = N
Brr(N, 1) = T: Brr(N, 2) = Arr(i, 2)
End If
For j = 3 To UBound(Arr, 2)
Brr(R, j) = Brr(R, j) + Val(Arr(i, j))
Next j
Next i
s01: Next
'------------------------------
With Sheets("匯總").[a5].Resize(N, 14)
.Value = Brr
.Columns(7) = "=rank(f5," & .Columns(6).Address & ")"
.Columns(14) = "=rank(M5," & .Columns(13).Address & ")"
End With
End Sub
Sub 清除()
Sheets("匯總").UsedRange.Offset(4).ClearContents
End Sub
Sub 載入()
Dim Arr, Brr, xD, T$, R&, N&, i&, j%, S As Worksheet
'↑宣告變數:(Arr, Brr, xD)是通用型變數,T是字串變數,(R,N,i)是長整數
'j是短整數,S是工作表變數
ReDim Brr(1 To 30000, 1 To 14)
'↑宣告Brr變數是二維陣列,縱向範圍從索引號1到30000,橫向範圍從1索引號到14
Call 清除
'↑令執行副程式 Sub 清除()
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典
For Each S In Sheets
'↑設逐項迴圈!令S變數是活頁簿裡的工作表
If S.Name = "匯總" Then GoTo s01
'↑如果S變數工作表名字是 "匯總" ,就跳到標示 s01 位置繼續執行
Arr = Range(S.[n1], S.[a65536].End(3))
'↑令Arr變數是二維陣列,以S變數工作表的[N1]到A欄最後有內容儲存格,
'令這儲存格範圍值帶入Arr陣列中
For i = 5 To UBound(Arr)
'↑設順迴圈從5 到Arr陣列最大索引列號
T = Arr(i, 1): R = xD(T)
'↑令T這字串變數是i迴圈列第1欄Arr陣列值
'令R這長整數變數是以T變數查xD字典item值(此key所在的Brr陣列列號)
If R = 0 Then
'↑如果R變數值是0 (代表此key首次納入xD字典中)
N = N + 1: R = N: xD(T) = N
'↑令N這長整數變數累加1 (這是要記錄Brr陣列用到了第幾列)
'令R變數值 = N變數值(意思是此key要放在Brr的N變數列)
'令xD字典中T變數key的item值換成N變數值(這是要記錄此key在Brr的列號)
Brr(N, 1) = T: Brr(N, 2) = Arr(i, 2)
'↑令N變數列第1欄Brr陣列值是T變數
End If
For j = 3 To UBound(Arr, 2)
'↑設順迴圈從3 到Arr陣列最大索引欄號
Brr(R, j) = Brr(R, j) + Val(Arr(i, j))
'↑令R變數列j迴圈欄Brr陣列值 累加Val函數值(i迴圈列j迴圈欄Arr陣列值)
Next j
Next i
s01: Next
'------------------------------
With Sheets("匯總").[a5].Resize(N, 14)
'↑以下是關於工作表"匯總" 的[A5]儲存格向下擴展N變數列,向右擴展14欄的儲存格範圍程序
.Value = Brr
'↑令該範圍儲存格值以Brr陣列值帶入
.Columns(7) = "=rank(f5," & .Columns(6).Address & ")"
'↑令第7欄值是 第6欄的排名
.Columns(14) = "=rank(M5," & .Columns(13).Address & ")"
'↑令第14欄值是 第13欄的排名
End With
End Sub
Sub 清除()
Sheets("匯總").UsedRange.Offset(4).ClearContents
'↑令"匯總" 工作表有使用的儲存格向下偏移4列的範圍儲存格清除內容
End Sub作者: Andy2483 時間: 2023-10-14 10:05
Option Explicit
Sub 載入_1()
Dim Arr, Brr(1 To 14), Z, A, T$, N&, i&, j%, q%
Sheets("匯總").UsedRange.Offset(4).ClearContents
Set Z = CreateObject("Scripting.Dictionary")
For q = 1 To Sheets.Count
If Trim(Sheets(q).[A5]) = "" Then GoTo q01
Arr = Range(Sheets(q).[n1], Sheets(q).[a65536].End(3))
For i = 5 To UBound(Arr)
T = Trim(Arr(i, 1)) & "|" & Trim(Arr(i, 2))
A = Z(T)
If Not IsArray(A) Then
A = Brr
A(1) = Trim(Arr(i, 1)): A(2) = Arr(i, 2)
End If
For j = 3 To UBound(Arr, 2)
A(j) = A(j) + Val(Arr(i, j))
Next
Z(T) = A
Next
q01: Next
'------------------------------
With Sheets("匯總").[A5].Resize(Z.Count, 14)
.Value = Application.Transpose(Application.Transpose(Z.Items))
.Sort KEY1:=.Item(1), Order1:=1, KEY2:=.Item(2), Order1:=1, Header:=2
.Columns(7) = "=rank(F5," & .Columns(6).Address(1, 1) & ")"
.Columns(14) = "=rank(M5," & .Columns(13).Address(1, 1) & ")"
End With
End Sub作者: Andy2483 時間: 2023-10-25 14:18
