返回列表 上一主題 發帖

請求改良程式

本帖最後由 Andy2483 於 2024-3-22 09:15 編輯

回復 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 "資料不符規則1": 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 "資料不符規則2": 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 "資料不符規則3": 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 "資料不符規則4": 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 21# Andy2483


謝謝前輩指點。在下圖第#014, 欄L 部分“()”不懂得刪除,請問以什麽規則來刪除的,我看看怎樣輸入來配合。

未命名.png
2024-3-22 15:15

TOP

回復 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 23# Andy2483

未命名.png
2024-3-22 16:16

我每次打開第一次執行都會有這個錯誤,然後我按結束,再按一次執行,就沒有問題。
不知道是哪方面的問題?

TOP

回復 24# 198188


    一樣,再研究看看
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 24# 198188

https://forum.twbts.com/viewthread.php?tid=4942
把按鈕移到 Sheet1 試試看
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 26# Andy2483


   
未命名.png
2024-3-25 16:27

也一樣有這個問題

TOP

回復 27# 198188

Sub Map()  改為   Sub Map_1()  後,將巨集重指定,試試看
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 28# Andy2483

未命名.png
2024-3-26 08:14

也一樣,有這個問題。

TOP

回復  198188

Option Explicit
Sub Map()
Application.DisplayAlerts = False: Application.ScreenUp ...
Andy2483 發表於 2024-3-22 08:51


前輩,可否給一下這個注釋,有的地方還是看不懂。

TOP

        靜思自在 : 我們要做好社會的環保,也要做好內心的環保。
返回列表 上一主題