Andy2483

¦^´_ 19# 198188

Option Explicit
Sub Map()
Application.DisplayAlerts = False: Application.ScreenUpdating = False
Dim A, D, Q, i&, N&, C%, j%, B6$, B7$, xM, T$, T0$, T1$, f%, u%, K, cc%, xR As Range, xA
For i = Worksheets.Count To 4 Step -1: Worksheets(i).Delete: Next
With Sheets(2): B6 = .[B6]: B7 = .[B7]: .[6:11].NumberFormat = "@": .[C6].Resize(10, 20).ClearContents: End With:
C = Sheets(1).UsedRange.Columns.Count
For Each xM In Intersect(Sheets(1).UsedRange, Sheets(1).[A:A])
   N = xM.MergeArea.Cells.Count: If N < 6 Or xM = "" Then GoTo M01 Else xA = Split(Trim(xM), " ")
   A = "#" & StrReverse(Mid(Val(1 & StrReverse(xA(0))), 2)): D = CDate(xA(1)): Q = xA(UBound(xA))
   If (Not A Like "[#]###") Or (IsError(D)) Or (Not Q Like "##?Q") Then MsgBox "¸ê®Æ¤£²Å³W«h1": Exit Sub
   With Sheets(2).Copy(after:=Worksheets(Sheets.Count)): With ActiveSheet: .Name = A
      [B3] = A: [F3] = Q: [I3] = D: [M4] = CDate(Date): u = 8: If .DrawingObjects.Count > 0 Then .DrawingObjects.Delete
      For i = 1 To 2
         For j = 2 To C
            T = Replace(Replace(Trim(xM(i, j)), "¡]", "("), "¡^", ")")
            If T = "" Then GoTo j01 Else Set xR = Cells(5 + i, (j - 1) * 2 + 1)
            If InStr(T, B6) Or InStr(T, B7) Then
               T = Replace(T, " ", ""): If Not T Like "*#(*)*" And T <> "" Then MsgBox "¸ê®Æ¤£²Å³W«h2": Exit Sub
               T0 = Trim(Mid(Split(T, "(")(0), 3)): T1 = "(" & Split(T, "(")(1)
               xR = T0: xR(1, 2) = T1: GoTo j01
            End If
            K = Split(T & Chr(10), Chr(10))
            For cc = 0 To UBound(K) - 1
               f = InStr(K(cc), " ")
               If f = 0 Then T0 = K(cc): T1 = "" Else T0 = Mid(K(cc), 1, f - 1): T1 = Mid(K(cc), f + 1)
               xR = IIf(xR = "", T0, xR & vbLf & T0): xR(1, 2) = IIf(xR(1, 2) = "", T1, xR(1, 2) & vbLf & T1)
            Next
j01:     Next
      Next
      For i = 3 To N - 3
         For j = 2 To C
            T = Replace(Replace(Replace(Trim(xM(i, j)), "¡]", "("), "¡^", ")"), "(", " (")
            If T = "" Then GoTo j02 Else Set xR = Cells(8, (j - 1) * 2 + 1)
            If InStr(T, B6) Or InStr(T, B7) Then
               T = Replace(T, " ", ""): If Not T Like "*#(*)*" And T <> "" Then MsgBox "¸ê®Æ¤£²Å³W«h3": Exit Sub
               T0 = Trim(Mid(Split(T, "(")(0), 3)): T1 = "(" & Split(T, "(")(1)
               xR = IIf(xR = "", T0, xR & vbLf & T0): xR(1, 2) = IIf(xR(1, 2) = "", T1, xR(1, 2) & vbLf & T1): GoTo j02
            End If
            f = InStr(T, " "): If f = 0 Then T0 = T: T1 = "" Else T0 = Mid(T, 1, f - 1): T1 = Trim(Mid(T, f + 1))
            xR = IIf(xR = "", T0, xR & vbLf & T0): xR(1, 2) = IIf(xR(1, 2) = "", T1, xR(1, 2) & vbLf & T1)
j02:     Next
      Next
      For i = N - 2 To N
         u = u + 1
         For j = 2 To C
            T = Replace(Replace(Trim(xM(i, j)), "¡]", "("), "¡^", ")")
            If T = "" Then GoTo j03 Else Set xR = Cells(u, (j - 1) * 2 + 1)
            If InStr(T, B6) Or InStr(T, B7) Then
               T = Replace(T, " ", ""): If Not T Like "*#(*)*" And T <> "" Then MsgBox "¸ê®Æ¤£²Å³W«h4": Exit Sub
               T0 = Trim(Mid(Split(T, "(")(0), 3)): T1 = "(" & Split(T, "(")(1)
               xR = T0: xR(1, 2) = T1: GoTo j03
            End If
            K = Split(T & Chr(10), Chr(10))
            For cc = 0 To UBound(K) - 1
               f = InStr(K(cc), " ")
               If f = 0 Then T0 = K(cc): T1 = "" Else T0 = Mid(K(cc), 1, f - 1): T1 = Mid(K(cc), f + 1)
               xR = IIf(xR = "", T0, xR & vbLf & T0): xR(1, 2) = IIf(xR(1, 2) = "", T1, xR(1, 2) & vbLf & T1)
            Next
j03:     Next
      Next
      For Each xR In .UsedRange.Offset(3).SpecialCells(2)
         If xR Like "(*)" Then xR = Mid(xR, 2, Len(xR) - 2) Else If xR Like "*[#]*" Then xR = Replace(xR, "#", "")
      Next
   End With: End With
M01: Next
End Sub

198188

¦^´_ 21# Andy2483


ÁÂÁ«e½ú«üÂI¡C¦b¤U¹Ï²Ä#014¡A ÄæL ³¡¤À¡§¡]¡^¡¨¤£À´±o§R°£¡A½Ð°Ý¥H¤°麽³W«h¨Ó§R°£ªº¡A§Ú¬Ý¬Ý«ç¼Ë¿é¤J¨Ó°t¦X¡C

¤U¸ü (34.55 KB)

2024-3-22 15:15

Andy2483

¦^´_ 22# 198188

For Each xR In .UsedRange.Offset(3).SpecialCells(2)
   If xR Like "(*)" Then xR = Mid(xR, 2, Len(xR) - 2) Else If xR Like "*[#]*" Then xR = Replace(xR, "#", "")
Next

§ï¬°

For Each xR In .UsedRange.Offset(3).SpecialCells(2)
   xR = Replace(Replace(Replace(xR, "(", ""), ")", ""), "#", "")
Next

198188

¦^´_ 23# Andy2483

¤U¸ü (100.6 KB)

2024-3-22 16:16

§Ú¨C¦¸¥´¶}²Ä¤@¦¸°õ¦æ³£·|¦³³o­Ó¿ù»~¡AµM«á§Ú«öµ²§ô¡A¦A«ö¤@¦¸°õ¦æ¡A´N¨S¦³°ÝÃD¡C
¤£ª¾¹D¬O­þ¤è­±ªº°ÝÃD¡H

Andy2483

¦^´_ 24# 198188


    ¤@¼Ë,¦A¬ã¨s¬Ý¬Ý

Andy2483

¦^´_ 24# 198188

https://forum.twbts.com/viewthread.php?tid=4942
§â«ö¶s²¾¨ì Sheet1 ¸Õ¸Õ¬Ý

198188

¦^´_ 26# Andy2483


   

¤U¸ü (86.58 KB)

2024-3-25 16:27

¤]¤@¼Ë¦³³o­Ó°ÝÃD

Andy2483

¦^´_ 27# 198188

Sub Map()  §ï¬°   Sub Map_1()  «á,±N¥¨¶°­««ü©w,¸Õ¸Õ¬Ý

198188

¦^´_ 28# Andy2483

¤U¸ü (182.33 KB)

2024-3-26 08:14

¤]¤@¼Ë¡A¦³³o­Ó°ÝÃD¡C

198188

¦^´_  198188

Option Explicit
Sub Map()
Application.DisplayAlerts = False: Application.ScreenUp ...
Andy2483 µoªí©ó 2024-3-22 08:51

«e½ú¡A¥i§_µ¹¤@¤U³o­Óª`ÄÀ¡A¦³ªº¦a¤èÁÙ¬O¬Ý¤£À´¡C