- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-12-18
|
8#
發表於 2022-5-16 17:47
| 只看該作者
回復 7# oak0723-1
已更新如下，請再測試看看，謝謝
另外"輸入"工作表要放在第1個
Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&, sh%, MaxR&
Set xD = CreateObject("Scripting.Dictionary")
Ar_in = Sheets("輸入").Range("i3:in3")
For sh = 2 To Sheets.Count
With Sheets(sh)
.Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
Arr1 = .Range(.[b5], .[b65536].End(3)): Arr = .Range("i3:in" & UBound(Arr1) + 4)
ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2)) 'IT3:RY
ReDim Preserve Crr(1 To 100000, 1 To sh - 1) '輸入的統計
If MaxR < UBound(Arr) Then MaxR = UBound(Arr)
Crr(1, sh - 1) = .Name
For x = 1 To UBound(Arr1)
If Arr1(x, 1) = "" Then GoTo 95
For i = 3 To UBound(Arr)
For j = 1 To UBound(Arr, 2)
T = Arr(i, j): T1 = Arr(1, j)
If T1 = "" Then GoTo 90
If T1 = T Then
Brr(i - 2, j) = 1: n = n + 1
Else
Brr(i - 2, j) = 0
End If
90: Next j
Crr(i - 1, sh - 1) = n: n = 0
Next i
95: Next x
.[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End With
Next
n = 0
With Sheets(1)
.[i4:r4].NumberFormatLocal = "@"
.[i4].Resize(MaxR, UBound(Crr, 2)) = Crr
With .[s5].Resize(MaxR - 2)
.Formula = "=Sum(i5:r5)": .Value = .Value
End With
With Range([s5], [s4].End(4))
Arr = .Value
.Sort Key1:=.Item(1), Order1:=2, Header:=2
Brr = .Value: .Value = Arr
End With
For i = 1 To UBound(Brr)
T = Brr(i, 1): If Not xD.Exists(T) Then n = n + 1: xD(T) = n
Next
For i = 1 To UBound(Arr): Arr(i, 1) = xD(Arr(i, 1)): Next
.[t5].Resize(UBound(Arr)) = Arr
End With
End Sub |
-
-
1.JPG
(144.75 KB)
|
