Andy2483

¦^´_ 2# aassddff736

ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«Øij§R°£½d¨ÒÀɸ̪º¦h¾lªÅÄæªÅ¦C,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

Option Explicit
Sub §R°£¦h¾lªÅÄæªÅ¦C()
Dim s As Worksheet, i&, j%, R&, C%
'¡ô«Å§iÅܼÆ:&¬Oªø¾ã¼Æ,%¬Oµu¾ã¼Æ
For Each s In Worksheets
'¡ô³]³v¶µ°j°é!¥OSÅܼƬO¬¡­¶Ã¯¸Ìªº¤u§@ªí
   Application.Goto s.[A1]: R = 0: C = 0
   '¡ô¥O´å¼Ð¸õ¨ì°j°é¤u§@ªíªºA1Àx¦s®æ,¥ORÅܼÆÂk¹s,¥OCÅܼÆÂk¹s
   With Range(s.[A1], s.UsedRange)
   '¡ô¥H¤U¬OÃö©óA1Àx¦s®æ¨ì¦³¨Ï¥ÎÀx¦s®æ³o½d³òÀx¦s®æªºµ{§Ç
      For j = 1 To .Cells.Columns.Count
      '¡ô³]¶¶°j°é!¥Oj±q1 ¨ì¸Ó½d³òªºÄæ¼Æ
         If R < Cells(Rows.Count, j).End(xlUp).Row Then R = Cells(Rows.Count, j).End(xlUp).Row
         '¡ô¦pªGRÅܼƤp©ó°j°éÄæ³Ì«á¦³¤º®eÀx¦s®æªº¦C¸¹,´N¥ORÅܼƬO¸Ó¦C¸¹¼Æ
      Next
      If .Rows.Count > R + 1 Then Rows(R + 1 & ":" & .Rows.Count).Delete
      '¡ô¦pªG½d³ò¦C¼Æ¤j©ó RÅܼÆ+1!´N¥O¦h¾lªº¦C§R°£
      For i = 1 To .Cells.Rows.Count
      '¡ô³]¶¶°j°é!¥Oi±q1 ¨ì¸Ó½d³òªº¦C¼Æ
         If C < Cells(i, Columns.Count).End(xlToLeft).Column Then C = Cells(i, Columns.Count).End(xlToLeft).Column
         '¡ô¦pªGCÅܼƤp©ó°j°é¦C³Ì«á¦³¤º®eÀx¦s®æªºÄ渹,´N¥OCÅܼƬO¸ÓÄ渹¼Æ
      Next
      If .Columns.Count > C + 1 Then Range(Cells(1, C + 1), Cells(1, .Columns.Count)).EntireColumn.Delete
      '¡ô¦pªG½d³òÄæ¼Æ¤j©ó CÅܼÆ+1!´N¥O¦h¾lªºÄæ§R°£
   End With
Next
End Sub

¸Õ°õ¦æ«á¥t¦s·sÀÉ

Andy2483

¦^´_ 5# aassddff736

¿ûªO½s¸¹¦³­«½Æ,»Ý¤â°Ê±Æ°£­«½Æ«á¤~Åã¥Ü·J¾ã¸ê®Æ:

¤U¸ü (119.22 KB)

2024-3-7 09:58

Option Explicit
Sub ¸ê®Æ·J¾ã¤J¥D­¶¿z¿ï°Ï()
Dim Brr, Crr, Z, Q, i&, j%, R&, N&, S, T$, E&, TT$
Set Z = CreateObject("Scripting.Dictionary")
With Sheets("¥D­¶")
   .Activate
   If .AutoFilter Is Nothing Then [B17:P17].AutoFilter Else If .FilterMode = True Then .ShowAllData
   With ActiveWindow
      .FreezePanes = False
      .ScrollRow = 13
      .SplitRow = 5
      .FreezePanes = True
   End With
   .UsedRange.Offset(17).EntireRow.Delete
   .[B:D].NumberFormat = "@"
   .[B:D].Font.Bold = True
End With
ReDim Crr(1 To 10000, 1 To 15)
Q = Array(Range([Àx¦ì!B3], [Àx¦ì!A65536].End(xlUp)), Range([Àx¦ì!E3], [Àx¦ì!D65536].End(xlUp)))
For Each Brr In Q
   Brr = Brr
   For i = 1 To UBound(Brr)
      N = N + 1: T = Brr(i, 2): Crr(N, 1) = Brr(i, 1): Crr(N, 2) = T: Z(T) = N
   Next
Next
E = N: Q = Array("1¦Ü588", "SUPER", "POWER", "POWER¸Õ²£", "TEST", "«Ý³ø¼o", "³ø¼o")
For Each S In Q
   Brr = Sheets(S).[A1].CurrentRegion
   For i = 3 To UBound(Brr)
      R = Z(Brr(i, 1))
      If Z.Exists(Brr(i, 2) & "|") Then TT = TT & " / " & S & "ªí_" & Brr(i, 2) Else Z(Brr(i, 2) & "|") = "A"
      If R = 0 Then N = N + 1: R = N
      For j = 1 To 14: Crr(R, j + 1) = Brr(i, j): Next
      If R > E Then Crr(R, 1) = S
   Next
Next
If N = 0 Then Exit Sub
If TT <> "" Then MsgBox "¿ûªO½s¸¹ " & Mid(TT, 4) & " ­«½Æ": Exit Sub
With [B18].Resize(N, 15): .Value = Crr: .Borders.LineStyle = 1: End With
End Sub

Sub ²M°£¥D­¶¿z¿ï°Ï¸ê®Æ()
With Sheets("¥D­¶")
   .Activate
   If .AutoFilter Is Nothing Then [B17:P17].AutoFilter Else If .FilterMode = True Then .ShowAllData
   With ActiveWindow: .FreezePanes = False: .ScrollRow = 1: .SplitRow = 17: .FreezePanes = True: End With
   .UsedRange.Offset(17).EntireRow.Delete
End With
End Sub

Andy2483

¦^´_  Andy2483


À³¬°¿ûªO·´·l©Ò¥H¶}·sªº·|¦³­«½Æ¿ûªO¸¹±¡ªp,¥i¥H¨Ì«e­±¬¡­¶¬°Àu¥ý¶Ü?°ò¥»³ø¼o°Ï¤£·| ...
aassddff736 µoªí©ó 2024-3-7 13:23

·Ó²z»¡¦P¿ûªO½s¸¹ °]²£½s¸¹­n¬Û¦P,¤U¹Ï©Ò¥Ü²£½s¸¹¤£¦P¦ó¦]?

¤U¸ü (96.39 KB)

2024-3-7 13:53

If TT <> "" Then MsgBox "¿ûªO½s¸¹ " & Mid(TT, 4) & " ­«½Æ" : Exit Sub
§ï¬°
If TT <> "" Then MsgBox "¿ûªO½s¸¹ " & Mid(TT, 4) & " ­«½Æ" ': Exit Sub

Andy2483

¦^´_ 9# aassddff736

1.¦pªG¿ûªO¨S¦³«Ø¥ßÀx¦ì½s¸¹ BÄæ¯d¥Õ,¦ý¬O³ø¼o»P±a³ø¼o¿ûªOBÄæÅã¥Ü
If R > E  Then Crr(R, 1) = S
§ï¬°
If R > E And InStr("«Ý³ø¼o", S) Then Crr(R, 1) = S

2.«ç»ò¬dªÅÀx¦ì?
¤â°Ê ¿z¿ïDÄæ > ªÅ®æ

Andy2483

¦^´_ 11# aassddff736

¦pªG¥þ³¡®æ¦¡³£­n¹L¥h,½Ð¥ý¦Û¤v¸ÕµÛ¿ý»s¥¨¶°,±µÀs¨ì¥D­¶ªí
µo¸ÜÃDªº½d¨ÒÀ³¸Ó­n§t®æ¦¡³£½Æ»s¹L¥hÅý¨ó§UªÌ©ú¥Õ»Ý¨D

Andy2483

¦^´_  Andy2483


    ¤]¬Oª½±µ¿z¿ï¤ñ¸û§Ö
aassddff736 µoªí©ó 2024-3-7 14:22

    ¸ê®Æ¦pªG¦³¶×¨ì¥D­¶,¿z¿ïªº°Ê§@¥N½X¿ý»s¥¨¶°´N¥i¥H¿ì¨ì

Andy2483

¦^´_ 11# aassddff736
ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú

¤U¸ü (316.17 KB)

2024-3-8 08:38

Option Explicit
Sub ¸ê®Æ·J¾ã¤J¥D­¶¿z¿ï°Ï()
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim Arr, Brr, Crr(1 To 10000, 1 To 1), Z, Q, i&, j%, R&, N&, S, T$, E&, TT$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
With Sheets("¥D­¶")
   .Activate: If .AutoFilter Is Nothing Then [B17:Q17].AutoFilter Else If .FilterMode = True Then .ShowAllData
   With ActiveWindow: .FreezePanes = False: .ScrollRow = 13: .SplitRow = 5: .FreezePanes = True: End With: .UsedRange.Offset(17).EntireRow.Delete
End With
Q = Array("1¦Ü588", "SUPER", "POWER", "POWER¸Õ²£", "TEST", "«Ý³ø¼o", "³ø¼o")
For Each S In Q
   Set xR = [D65536].End(3)(2, 0): If Sheets(S).FilterMode = True Then Sheets(S).ShowAllData
   R = Sheets(S).[B65536].End(3).Row - 2: Sheets(S).[A3].Resize(R, 14).Copy xR: If InStr("«Ý³ø¼o", S) Then xR.Resize(R, 1).Offset(, -1) = S
Next
Set Brr = Range([P18], [D65536].End(3)(1, -1)): Brr.Font.Size = 8: N = Brr.Rows.Count: Brr = Brr.Resize(10000).Resize(, 2)
For i = 1 To UBound(Brr): Z(Brr(i, 2)) = i: Next: Z.Remove ("")
Q = Array(Range([Àx¦ì!B3], [Àx¦ì!A65536].End(xlUp)), Range([Àx¦ì!E3], [Àx¦ì!D65536].End(xlUp)))
For Each Arr In Q
   Arr = Arr
   For i = 1 To UBound(Arr)
      T = Arr(i, 2): If Z.Exists(T) Then Brr(Z(T), 1) = Arr(i, 1) Else N = N + 1: Brr(N, 1) = Arr(i, 1): Brr(N, 2) = Arr(i, 2)
   Next
Next
With [B18].Resize(N, 2): .Value = Brr: .Resize(, 15).Borders.LineStyle = 1: .EntireRow.AutoFit: End With: Call µù¸Ñ_½Õ¾ã¦Ü«ü©w¦ì¸m
End Sub
Sub µù¸Ñ_½Õ¾ã¦Ü«ü©w¦ì¸m()
Dim CO As Comment, SL&, ST&
For Each CO In ActiveSheet.Comments
   With CO
      With Range(.Parent.Address): SL = .Left + .Width + 10: ST = .Top + 10: End With: With .Shape: .Left = SL: .Top = ST: End With
     .Shape.TextFrame.Characters.Font.Size = 12: .Shape.DrawingObject.AutoSize = True
   End With
Next
Application.DisplayCommentIndicator = -1
End Sub
Sub ²M°£¥D­¶¿z¿ï°Ï¸ê®Æ()
With Sheets("¥D­¶")
   .Activate: If .AutoFilter Is Nothing Then [B17:Q17].AutoFilter Else If .FilterMode = True Then .ShowAllData
   With ActiveWindow: .FreezePanes = False: .ScrollRow = 1: .SplitRow = 17: .FreezePanes = True: End With: .UsedRange.Offset(17).EntireRow.Delete
End With
End Sub
Sub ¥D­¶¿z¿ï°Ï¸ê®Æ_¥þ³¡Åã¥Ü()
With Sheets("¥D­¶")
   .Activate: If .AutoFilter Is Nothing Then [B17:Q17].AutoFilter Else If .FilterMode = True Then .ShowAllData
   With ActiveWindow: .FreezePanes = False: .ScrollRow = 13: .SplitRow = 5: .FreezePanes = True: .ScrollRow = 1: End With
   If .[D65536].End(3).Row = 17 Then Call ¸ê®Æ·J¾ã¤J¥D­¶¿z¿ï°Ï
End With
End Sub
Sub ªÅÀx¦ì()
Call ¥D­¶¿z¿ï°Ï¸ê®Æ_¥þ³¡Åã¥Ü: Selection.AutoFilter Field:=2, Criteria1:="<>": Selection.AutoFilter Field:=3, Criteria1:="="
End Sub
Sub ¨S¦³Àx¦ìªº¿ûªO()
Call ¥D­¶¿z¿ï°Ï¸ê®Æ_¥þ³¡Åã¥Ü: Selection.AutoFilter Field:=3, Criteria1:="<>": Selection.AutoFilter Field:=2, Criteria1:="="
End Sub

Andy2483

¦^´_ 19# aassddff736

Sub ¸ê®Æ·J¾ã¤J¥D­¶¿z¿ï°Ï()
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim Arr, Brr, Crr(1 To 10000, 1 To 1), Z, Q, i&, j%, R&, N&, S, T$, E&, TT$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
With Sheets("¥D­¶")
   .Activate: If .AutoFilter Is Nothing Then [B17:Q17].AutoFilter Else If .FilterMode = True Then .ShowAllData
   With ActiveWindow: .FreezePanes = False: .ScrollRow = 13: .SplitRow = 5: .FreezePanes = True: End With: .UsedRange.Offset(17).EntireRow.Delete
End With
Q = Array("1¦Ü588", "SUPER", "POWER", "POWER¸Õ²£", "TEST", "«Ý³ø¼o", "³ø¼o")
For Each S In Q
   Set xR = [D65536].End(3)(2, 0): If Sheets(S).FilterMode = True Then Sheets(S).ShowAllData
   R = Sheets(S).[B65536].End(3).Row - 2: Sheets(S).[A3].Resize(R, 14).Copy xR: If InStr("«Ý³ø¼o", S) Then xR.Resize(R, 1).Offset(, -1) = S
   For i = 1 To xR.Resize(R, 1).Offset(, -2).Count
      ActiveSheet.Hyperlinks.Add Anchor:=xR.Resize(R, 1).Offset(, 1)(i), Address:="", SubAddress:=S & "!A" & i + 2 & ":O" & i + 2
   Next
Next
Set Brr = Range([P18], [D65536].End(3)(1, -1)): Brr.Font.Size = 8: Brr.Columns(3).Font.Size = 12: N = Brr.Rows.Count: Brr = Brr.Resize(10000).Resize(, 2)
For i = 1 To UBound(Brr): Z(Brr(i, 2)) = i: Next: Z.Remove ("")
Q = Array(Range([Àx¦ì!B3], [Àx¦ì!A65536].End(xlUp)), Range([Àx¦ì!E3], [Àx¦ì!D65536].End(xlUp)))
For Each Arr In Q
   Arr = Arr
   For i = 1 To UBound(Arr)
      T = Arr(i, 2): If Z.Exists(T) Then Brr(Z(T), 1) = Arr(i, 1) Else N = N + 1: Brr(N, 1) = Arr(i, 1): Brr(N, 2) = Arr(i, 2)
   Next
Next
With [B18].Resize(N, 2): .Value = Brr: .Resize(, 15).Borders.LineStyle = 1: .EntireRow.AutoFit: End With: Call µù¸Ñ_½Õ¾ã¦Ü«ü©w¦ì¸m
End Sub

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

Andy2483

¦^´_ 25# aassddff736


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