¥ÎVBA°µ¬d¸ß¨t²Î

aassddff736

½Ð±Ð¦U¦ì«e½ú

§Ú¦³¤@­ÓÀx¦ìªí³æ,¤»­Ó¿ûªO¤u§@ªí¸ê®Æ
·Q­n¦b«Ø¥ß¥D­¶°µ¬d¸ß¨t²Î:¬d¿ûªO¸ê®Æ,©ñ¸mÀx¦ì,ÁÙ¦³­þ¨ÇªÅÀx¦ì ,©|¥¼«Ø¥ßÀx¦ìªº¿ûªO
Àx¦ì¬d¸ß¨t²Î.rar (246.13 KB)

¤U¸ü¦¸¼Æ: 15

2024-3-3 15:55

¿ûªO¸ê®Æ±`±`·|·s¼W¤Î§R°£¶µ¥Ø
Àx¦ì¤]±`±`·|ÅÜ´«©ñ¸mªº¿ûªO

aassddff736

¦^´_ 30# Andy2483 [/b
¤F¸Ñ

Andy2483

¦^´_ 29# aassddff736

¯Â½m²ß,½Ð°Ñ¦Ò,¥Øªº¬O¾ã²z¥X¨C­ÓÄæ¦ì¿é¤J¹Lªº¶µ¥Ø(¤£­«½Æ¨Ã¥B°µ±Æ§Ç)
°õ¦æµ²ªG:

¤U¸ü (330.75 KB)

2024-3-27 14:05

aassddff736

¦^´_ 28# Andy2483
¨S¦³©ú¥Õ

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

Option Explicit
Sub ¤£­«½Æ¦UÄæ©ú²Ó()
Dim Brr, Crr, Z, Q, i&, j%, R&, T$, x%, Rm&
Set Z = CreateObject("Scripting.Dictionary")
Brr = Intersect([¥D­¶!B17].CurrentRegion, [¥D­¶!B17:P65536])
ReDim Crr(10000, 1 To UBound(Brr, 2))
For j = 1 To UBound(Brr, 2)
   For i = 2 To UBound(Brr)
      Q = Split(Brr(i, j) & Chr(10), Chr(10))
      For x = 0 To UBound(Q) - 1
         T = Trim(Q(x))
         If Not Z.Exists(T) And T <> "" Then R = R + 1: Crr(R, j) = T: Z(T) = "": Rm = IIf(R > Rm, R, Rm)
      Next
   Next
   Crr(0, j) = Brr(1, j): R = 0: Z.RemoveAll
Next
Workbooks.Add
With [A1].Resize(Rm + 1, UBound(Brr, 2))
   .NumberFormat = "@": .Value = Crr: .EntireColumn.AutoFit
   For j = 1 To UBound(Brr, 2): .Columns(j).Sort KEY1:=.Cells(1, j), Order1:=1, Header:=1: Next
End With
End Sub

aassddff736

¦^´_ 26# Andy2483


¤F¸Ñ
«D±`·PÁ±z

Andy2483

¦^´_ 25# aassddff736


«á¾Ç¥H©¹¸ê®Æ³B²z¤è¦¡³£¬O ¥D­¶¬°¥D,¥²­n®É¦A¤ÀÀÉ°µ²Î­p,¤ÀÀɥΧ¹´N²M°£,ÁÂÁ«e½ú

aassddff736

¦^´_ 23# Andy2483
§Ú¸Õ¤F¸õ¦^"²M°£¥D­¶¿z¿ï°Ï¸ê®Æ"·|³ø¿ù
ªÅÀx¦ì¿z¿ï¸ê®Æ¯àª½±µ®M¦b¬¡­¶¸ê®Æ¤Uµ¹¶Ü ´N¤£¥Î¸õ¨ì¥D­¶
attachimg]37628[/attachimg]

¤U¸ü (51.26 KB)

2024-3-26 13:01

aassddff736

¦^´_ 23# Andy2483
ÁÂÁ±z
§Ú¸Õ¸Õ

Andy2483

¦^´_ 22# aassddff736


¥H¤U¬O ¾Ç²ß¸ê®ÆÅçÃÒ²M³æªº¤èªk,½Ð«e½ú°Ñ¦Ò
Àx¦ìªÅ¦ì¦s©ñ°Ï²M³æ:

¤U¸ü (199.68 KB)

2024-3-26 11:10

Àx¦ìªÅ¦ì²M³æ:

¤U¸ü (202.83 KB)

2024-3-26 11:12

±N¥H¤U¥N½X´Ó¤J ¥D­¶ ¤u§@ªí¼Ò²Õ¤U
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
   Dim Ad$, Arr, Z, xR As Range, i&
   Set Arr = Intersect([¥D­¶!B17].CurrentRegion, [¥D­¶!B18:D65536])
   If Me.UsedRange.Rows.Count <= 17 Then Exit Sub
   If .Columns.Count > 1 Then Exit Sub
   Set xR = Intersect(Arr.Resize(, 1), .Cells): Arr.Resize(, 2).Validation.Delete
   If Not xR Is Nothing Then
      If .Count > 1 Then Exit Sub
      If Trim(.Value) = "" Then Exit Sub Else Arr = Arr
      Set Z = CreateObject("Scripting.Dictionary")
      For i = 1 To UBound(Arr)
         If Arr(i, 1) = .Value And Arr(i, 3) = "" Then Z(Arr(i, 2)) = ""
      Next
      With .Item(1, 2).Validation
         If Z.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
         xlBetween, Formula1:=Join(Z.KEYS(), ",")
      End With
      Set Z = Nothing: Arr = Empty: Exit Sub
   End If
   Set xR = Intersect(Arr.Resize(, 2), .Cells)
   If Not xR Is Nothing Then
      If .Count > 1 Then Exit Sub
      If .Value = "" Then Exit Sub Else Arr = Arr
      Set Z = CreateObject("Scripting.Dictionary")
      For i = 1 To UBound(Arr): Z(Arr(i, 1) & "/" & Arr(i, 2)) = i + 17: Next
      If Z.EXISTS(.Item(1, 0) & "/" & .Value) Then Rows(Z(.Item(1, 0) & "/" & .Value)).Delete
      Ad = .Cells(1, 2).Hyperlinks(1).SubAddress
      Application.Goto Sheets(Split(Ad, "!")(0)).Range(Split(Ad, "!")(1))
      Selection(1) = .Value: Set Z = Nothing: Arr = Empty
   End If
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Arr, Z, i&, xR As Range
With Target
   Set Arr = Intersect([¥D­¶!B17].CurrentRegion, [¥D­¶!B18:D65536])
   Set xR = Intersect(Arr.Resize(, 1), .Cells): Arr.Resize(, 1).Validation.Delete: Arr = Arr
   If Not xR Is Nothing Then
      Set Z = CreateObject("Scripting.Dictionary")
      For i = 1 To UBound(Arr)
         If Arr(i, 1) <> "" And Arr(i, 3) = "" Then Z(Arr(i, 1)) = ""
      Next
      With .Validation
         If Z.Count > 0 Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
         xlBetween, Formula1:=Join(Z.KEYS(), ","): Set Z = Nothing: Arr = Empty
      End With
   End If
End With
End Sub