Option Explicit
Sub TEST()
Dim A As Range, i%, Z
Set Z = CreateObject("Scripting.Dictionary")
For Each A In Intersect(ActiveSheet.UsedRange, [B:B,D:D,F:F]).SpecialCells(2)
If A.Item(1, 0) = "" Then GoTo A01
For i = 1 To Len(A & "")
If A.Characters(i, 1).Font.Strikethrough = True Then GoTo A01
Next
If Z(Val(A.Item(1, 0))) = "" Then Z(Val(A.Item(1, 0))) = A
A01: Next
With [H2].Resize(Z.Count, 2)
Intersect(ActiveSheet.UsedRange, .EntireColumn).Offset(1).ClearContents
.Columns(1) = Application.Transpose(Z.Keys)
.Columns(2) = Application.Transpose(Z.Items)
.Sort KEY1:=.Item(1), Order1:=1, Header:=2
End With
End Sub作者: 爆肝達人 時間: 2023-11-24 10:05
工作表模組
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If Intersect(.Cells, [A:F]) Is Nothing Then Exit Sub Else Call Ex
End With
End Sub
一般模組:
Option Explicit
Sub Ex()
Dim Arr, A, i%, Z
Set Z = CreateObject("Scripting.Dictionary")
Set Arr = CreateObject("System.Collections.ArrayList")
For Each A In Intersect(ActiveSheet.UsedRange, [B:B,D:D,F:F]).SpecialCells(2)
If A.Item(1, 0) = "" Then GoTo A01
For i = 1 To Len(A & "")
If A.Characters(i, 1).Font.Strikethrough = True Then GoTo A01
Next
If Z(Val(A.Item(1, 0))) = "" Then Z(Val(A.Item(1, 0))) = A
A01: Next
For Each A In Z.Keys
If A <> vbNullString And Not Arr.contains(A) Then Arr.Add (A)
Next
Arr.Sort: Arr = Arr.toarray
ReDim A(UBound(Arr), 1 To 2)
For i = 0 To UBound(Arr): A(i, 1) = Arr(i): A(i, 2) = Z(Arr(i)): Next
With [H2].Resize(Z.Count, 2)
Intersect(ActiveSheet.UsedRange, .EntireColumn).Offset(1).ClearContents
.Value = A
End With
End Sub作者: 爆肝達人 時間: 2023-11-27 10:49
