Andy2483

¦^´_ 1# Ãz¨x¹F¤H


    ÁÂÁ½׾Â,ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹©«¾Ç²ß¥H«e«e½ú­Ìªº°Ýµª,¾Ç¨ì«Ü¦hª¾ÃÑ
https://forum.twbts.com/viewthre ... =Font.Strikethrough

¥H¤U¾Ç²ßªº¤è®×,½Ð«e½ú°Ñ¦Ò
¦pªG¼Æ¦r¦³­«½Æ¥u¨ú²Ä1µ§¹ïÀ³¦r¦ê

°õ¦æµ²ªG:

¤U¸ü (123.16 KB)

2023-11-24 08:10

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

Andy2483

¦^´_ 4# Ãz¨x¹F¤H


    ÁÂÁ«e½ú¦^´_
¥H¤U¬O½m²ßIJµo©I¥s°Æµ{¦¡ªº¤è®×,½Ð«e½ú°Ñ¦Ò
´ú¸Õ_20231124.zip (16.32 KB)

¤U¸ü¦¸¼Æ: 2

2023-11-24 15:46

¤u§@ªí¼Ò²Õ
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