麻辣家族討論版版 - Powered by Discuz! Board

標題: 請求改良程式 [打印本頁]

作者: 198188 時間: 2024-3-13 18:10 標題: 請求改良程式

[attach]37584[/attach]
請求改良程式：
下面程式有下面問題：
1）如果Sheet1在 B欄沒有資料的，後面C欄-F欄資料都不會顯示出來。
2）原設計沒有中箱一行
3）資料庫輸入有時會有微改

現想修改比較簡單的規則，只修改圖片部分的規則。
圖片下方是資料庫，每個都固定有5行，但不固定欄數
左上圖為固定模板，按照下方資料庫的位置，排入固定模板。

分割兩欄，
如果有"SR" , 第一欄抽取SR開始到 "（" 或者  ” “ 空格;
如果沒有"SR" ,第一欄抽取從第一個字到 ” “ 空格;
舉例
"下架 SR1106(15F单元)" 抽取 "SR1106"
"SR02 SM-057-094S (T-bolt螺丝垫片)" 抽取 "SR02"
"#2312302240 門框玻璃 280MM =4PCS"  抽取 "#2312302240"
"W001 (OT3工程门玉玻璃GL1-008)" 抽取 "W001"

第二欄抽取第一欄抽取后的所有資料，如果頭尾是“（”“）”就去掉
舉例
"下架 SR1106(15F单元)" 抽取 "15F单元"
"SR02 SM-057-094S (T-bolt螺丝垫片)" 抽取 "SM-057-094S (T-bolt螺丝垫片"
"#2312302240 門框玻璃 280MM =4PCS"  抽取 "門框玻璃 280MM =4PCS"
"W001 (OT3工程门玉玻璃GL1-008)" 抽取 "OT3工程门玉玻璃GL1-008"

Sub Map()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Brr, Crr, Ar, Arr, V, Z, A, i&, r&, C%, j%, T$, K$, Qs$, Qd$, No$, Mk$, Q$
For i = Worksheets.Count To 4 Step -1: Worksheets(i).Delete: Next
Set Z = CreateObject("Scripting.Dictionary")
Brr = Union(Sheets(1).UsedRange, Sheets(1).UsedRange.Offset(1))
Crr = Range(Sheets(2).[A1], Sheets(2).UsedRange): K = [B1]
For i = 1 To UBound(Brr) - 1
If InStr(Brr(i, 1), Left(K, 4)) = 0 Then GoTo i01
A = Split(Replace(Brr(i, 1), "  ", " "), " "): Q = Mid(A(0), 5, 4): Qd = A(1)
If UBound(A) > 1 Then Qs = A(UBound(A)) Else Qs = ""
A = Z(Q): r = Z(Q & "/r"): C = 1
If Not IsArray(A) Then A = Crr: A(3, 2) = Q: A(3, 6) = Qs: A(3, 9) = Qd: A(4, 13) = Date: r = 5
r = r + 1: V = A(r, 2)
If InStr(Brr(i, 2), V) = 0 Or r = 10 Then GoTo i01
For j = 2 To UBound(Brr, 2)
   C = C + 2: T = Trim(Brr(i, j)): If T = "" Then GoTo j01
   If InStr(T, V) Then
      A(r, C) = Mid(T, 4, 6): A(r, C + 1) = Replace(Mid(T, 11), ")", "")
      Else
      Ar = Split(T, Chr(10))
      For Each Arr In Ar
         If Not Split(Arr & " ", " ")(1) Like "[A-z][A-z]" Then GoTo j01
         No = No & Chr(10) & Split(Arr, " ")(0)
         Mk = Mk & Chr(10) & Mid(Arr, InStr(Arr, Split(Arr, " ")(1)))
      Next
      A(r, C) = Mid(No, 2): A(r, C + 1) = Mid(Mk, 2): No = "": Mk = ""
   End If
j01: Next
Z(Q) = A: Z(Q & "/r") = r
i01: Brr(i + 1, 1) = IIf(Brr(i + 1, 1) = "", Brr(i, 1), Brr(i + 1, 1))
Next
If Z.Count = 0 Then Exit Sub
For Each A In Z.KEYS
If Not IsArray(Z(A)) Then GoTo A01
With Sheets(2).Copy(after:=Worksheets(Sheets.Count))
   ActiveSheet.Name = A
   [A1].Resize(UBound(Z(A)), UBound(Z(A), 2)) = Z(A)
End With
A01: Next
Application.Goto Sheets(1).[A1]
End Sub

作者: Andy2483 時間: 2024-3-15 15:02

回復 1# 198188

這範例檔與之前話題的範例檔資料需要更多判斷才能釐清其為上架或下架,後學認為資料要進步性
建議前輩多練習,因應這些資料的變化修改程式

[attach]37591[/attach]

作者: 198188 時間: 2024-3-15 15:47

回復 2# Andy2483

[attach]37592[/attach]

原本的程式是分上架 & 下架來分辨。

因爲實際情況調整了，所以改爲按照改下圖工程内5行來直接分配入上圖的5行内。

而欄位同樣分割兩部分，套入2個欄位, A / B 欄
欄位内的規則有少許改動。
首欄  A：
如果有 "SR", 就抽取從“SR" 開始計算到下一個 "空格" / "("
舉例
下架 SR7000 (22F)             => SR7000
上架 SR70 (22F)                => SR70
下架SR700(2F)                   => SR700
SR12(32F)                            =>SR12
如果沒有"SR", 就抽取第一個字到第一個空格
舉例
W201 (3-10F)                                     =>W201
2312302240 GLASS                         => 2312302240
#2402190275 WING                         =>#2402190275
TENU7325721-1 GLASS                   =>TENU7325721-1

首欄  B：
抽取首欄A之後的字元，如果首尾是”（）“就去掉”（）“
舉例
W201 (3F-5F單元)                                        =>3F-5F單元
2312302240 GLASS                                     => GLASS
#2402190275 WING                                  =>WING
TENU7325721-1(5-6F水槽)1500*1200 =>  5-6F水槽)1500*1200
下架 SR7000 WINDOW(22F)                                        => WINDOW(22F
上架 SR70 (22F)                                           => 22F
下架SR700 (2F)                                              => 2F
SR12 (32F)                                                    =>32F

作者: Andy2483 時間: 2024-3-15 16:06

回復 3# 198188

#2312302239 門框玻璃 550MM =11PCS
#2312302236 門框玻璃 300MM =4PCS
#2312302240 門框玻璃 280MM =4PCS
#2402190275 門框玻璃 300MM =4PCS
這些沒辦法判定上架或下架

作者: 198188 時間: 2024-3-15 17:42

回復 4# Andy2483

#2312302239 門框玻璃 550MM =11PCS
#2312302236 門框玻璃 300MM =4PCS
#2312302240 門框玻璃 280MM =4PCS
#2402190275 門框玻璃 300MM =4PCS
下架 SR7006 (07F門玉）
這裏是5行

全部按照資料的順序排列
Sheet1 工作頁第一行 #2312302239 門框玻璃 550MM =11PCS 等於 MAP 工作頁第6列最一行的上架
Sheet1 工作頁第二行 #2312302236 門框玻璃 300MM =4PCS    等於 MAP 工作頁第7列最二行的下架
Sheet1 工作頁第三行 #2312302240 門框玻璃 280MM =4PCS    等於 MAP 工作頁第8列最三行的中箱
Sheet1 工作頁第四行 #2402190275 門框玻璃 300MM =4PCS    等於 MAP 工作頁第9列最四行的上架
Sheet1 工作頁第五行下架 SR7006 (07F門玉）                               等於 MAP 工作頁第10列  最五行的下架

不需要根據上架 / 下架來讀取

作者: Andy2483 時間: 2024-3-15 18:40

本帖最後由 Andy2483 於 2024-3-15 18:42 編輯

回復 5# 198188

如果超過10項11.12.13....等表又會怎麼變？
與決策者多討論各種不同狀況，手動試行看看

作者: 198188 時間: 2024-3-16 10:14

本帖最後由 198188 於 2024-3-16 10:16 編輯

回復 6# Andy2483

[attach]37595[/attach][attach]37596[/attach]
[attach]37597[/attach][attach]37598[/attach][attach]37599[/attach]

"MAP" 工作表模板固定行數5行（列6 "上架"，列7 "下架"，列8 "中箱"，列9 "上架"，列10 "下架"), 欄位固定從欄C開始，欄數不固定，取決于 "SHEET1"資料庫

"SHEET1" 工作表資料庫，行數最少5行，欄位固定從欄B開始，欄數不固定

對應數據的規則
Sheet1 該組的第一行  對應 MAP 列6 "上架"
Sheet1 該組的第二行  對應 MAP 列7 "下架"

Sheet1 該組的第三行（或者第三行至尾三行）  對應 MAP 列8 "中箱"，如上圖藍色部分
舉例如果總共6行，第3，4行對應 MAP 列8 "中箱"；如果總共7行，第3，4，5行對應 MAP 列8 "中箱"，如果總共8行，第3，4，5，6行對應 MAP 列8 "中箱"，如此類推

Sheet1 該組的尾二行  對應 MAP 列9 "上架"
Sheet1 該組的第尾行  對應 MAP 列10 "下架"

Sheet1 欄B 對應 MAP 欄 C&D，欄C 抽取（如有 "SR" ，從"SR"開始到第一個空格或者 "(" ;  如沒有"SR" ，從第1個字到第一個空格或者 "(" ，並刪除符號 "#" 如有）；欄D 抽取 (欄C 取到的字元之後的所有字元，並刪除符號 "(" & ")" 如有)
Sheet1 欄C 對應 MAP 欄 E&F，欄E 抽取（如有 "SR" ，從"SR"開始到第一個空格或者 "(" ;  如沒有"SR" ，從第1個字到第一個空格或者 "(" ，並刪除符號 "#" 如有）；欄F 抽取 (欄C 取到的字元之後的所有字元，並刪除符號 "(" & ")" 如有)
Sheet1 欄D 對應 MAP 欄 G&H，欄G 抽取（如有 "SR" ，從"SR"開始到第一個空格或者 "(" ;  如沒有"SR" ，從第1個字到第一個空格或者 "(" ，並刪除符號 "#" 如有）；欄H抽取 (欄C 取到的字元之後的所有字元，並刪除符號 "(" & ")" 如有)
Sheet1 欄E 對應 MAP 欄 I&J ，如上
Sheet1 欄F 對應 MAP 欄 K&L ，如上
Sheet1 欄G 對應 MAP 欄 M&N ，如上
Sheet1 欄H 對應 MAP 欄 O&P  ，如上
如此類推

作者: Andy2483 時間: 2024-3-19 08:22

回復 7# 198188

謝謝前輩回復
這範例的需求還一直在變化需求,建議先手動執行一段時間後,等定案了再以VBA自動化處理

作者: 198188 時間: 2024-3-19 08:59

回復 8# Andy2483

#06 是最終的變化了，之前的操作是初步了解。已經經過三個月的測試，才有這個定案。

作者: Andy2483 時間: 2024-3-20 07:38

回復 9# 198188

謝謝前輩回復
查看了範例,每個櫃子的規則都不相同,自由度非常高,不適合寫程式自動完成
[attach]37603[/attach]

[attach]37604[/attach]

作者: 198188 時間: 2024-3-20 08:54

回復 10# Andy2483

[attach]37607[/attach][attach]37608[/attach]

沒有上箱，下箱複製上錯誤。全部都是“上架”，“中箱”，“下架”。
我將Sheet1 & Map 相對的數據，貼在上面同一個圖片，並加入注釋，以便清晰了解。
如果同一個儲存格内有兩個數據，分辨困難的話，可以忽略，將它當作一個數據來做

一個儲存格内有兩個數據，第兩個數據會分開并列，如下。
W105  AA工程FC116 1幅
#2311200805 (VP工程5F栏杆玻璃)=1p

W105 AA工程FC116 1幅
2311200805  VP工程5F栏杆玻璃=1p

如果上面效果分辨困難，就當作一個數據操作，其餘的手動修改，如下：
W105  AA工程FC116 1幅
#2311200805 (VP工程5F栏杆玻璃)=1p

W105 AA工程FC116 1幅    #2311200805 VP工程5F栏杆玻璃=1p

作者: Andy2483 時間: 2024-3-20 09:19

回復 11# 198188

請上傳完整有規則的範例

作者: 198188 時間: 2024-3-20 10:02

回復 12# Andy2483

以“Sheet1“ 工作表欄A來為依據，用MAP模板分拆不同Sheet
取欄A 以 “#” 開始到第一個空格來命名Sheet Name, 及錄入“B3”儲存格内
Sheet Name空格后的日期，錄入到Map “i3”儲存格内
日期后的45HQ, 40HC, 40GP, 40OT, 40RF, 20GP, 錄入到Map“F3”儲存格内
Map“M4”儲存格内 = TODAY

"MAP" 工作表模板固定行數5行（列6 "上架"，列7 "下架"，列8 "中箱"，列9 "上架"，列10 "下架"), 欄位固定從欄C開始，欄數不固定，取決于 "SHEET1"資料庫

"SHEET1" 工作表資料庫，行數最少5行，欄位固定從欄B開始，欄數不固定

對應數據的規則
欄位規則對應：
Sheet1 欄B 對應 MAP 欄 C&D，
欄C 抽取（如有 "SR" ，從"SR"開始到第一個空格或者 "(" ;  如沒有"SR" ，從第1個字到第一個空格或者 "(" ，並刪除符號 "#" 如有）；
欄D 抽取 (欄C 取到的字元之後的所有字元，並刪除符號 "(" & ")" 如有)

Sheet1 欄C 對應 MAP 欄 E&F，
欄E 抽取（如有 "SR" ，從"SR"開始到第一個空格或者 "(" ;  如沒有"SR" ，從第1個字到第一個空格或者 "(" ，並刪除符號 "#" 如有）；
欄F 抽取 (欄C 取到的字元之後的所有字元，並刪除符號 "(" & ")" 如有)

Sheet1 欄D 對應 MAP 欄 G&H，
欄G 抽取（如有 "SR" ，從"SR"開始到第一個空格或者 "(" ;  如沒有"SR" ，從第1個字到第一個空格或者 "(" ，並刪除符號 "#" 如有）；
欄H抽取 (欄C 取到的字元之後的所有字元，並刪除符號 "(" & ")" 如有)

Sheet1 欄E 對應 MAP 欄 I&J ，如上
Sheet1 欄F 對應 MAP 欄 K&L ，如上
Sheet1 欄G 對應 MAP 欄 M&N ，如上
Sheet1 欄H 對應 MAP 欄 O&P  ，如上
如此類推

如果欄位内一個儲存格内有兩組或以上數據。
一個儲存格内有兩個數據，第兩個數據會分開并列，如下。
W105  AA工程FC116 1幅
#2311200805 (VP工程5F栏杆玻璃)=1p

W105 AA工程FC116 1幅
2311200805  VP工程5F栏杆玻璃=1p

如果上面效果分辨困難，就當作一個數據操作，其餘的手動修改，如下：
W105  AA工程FC116 1幅
#2311200805 (VP工程5F栏杆玻璃)=1p

W105 AA工程FC116 1幅    #2311200805 VP工程5F栏杆玻璃=1p

列位規則對應：

Sheet1 該組的第一列  對應 MAP 列6 "上架"
Sheet1 該組的第二列  對應 MAP 列7 "下架"

Sheet1 該組的第三列（或者第三行至尾三行）
舉例Sheet1,
如果總共6列，第3，4列對應 MAP 列8 "中箱"；第3，4列的分拆欄位數據錄入同一個相對應的欄位

如果總共7列，第3，4，5列對應 MAP 列8 "中箱"，第3，4，5列的分拆欄位數據錄入同一個相對應的欄位

如果總共8列，第3，4，5，6列對應 MAP 列8 "中箱"第3，4，5，6列的分拆欄位數據錄入同一個相對應的欄位

如此類推

Sheet1 該組的尾二列  對應 MAP 列9 "上架"
Sheet1 該組的第尾列  對應 MAP 列10 "下架"

作者: Andy2483 時間: 2024-3-21 11:58

回復 7# 198188

謝謝論壇,謝謝各位前輩
後學藉此帖練習VBA,學習方案如下,請前輩參考

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%
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
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
   If .DrawingObjects.Count > 0 Then .DrawingObjects.Delete
   [B3] = A: [F3] = Q: [I3] = D: [M4] = Date
   For i = 1 To 2
      For j = 2 To C
         T = Replace(Replace(Trim(xM(i, j)), "（", "("), "）", ")")
         If T = "" Then GoTo j01
         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)
            Cells(5 + i, (j - 1) * 2 + 1) = T0: Cells(5 + i, (j - 1) * 2 + 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)
            Cells(5 + i, (j - 1) * 2 + 1) = IIf(Cells(5 + i, (j - 1) * 2 + 1) = "", T0, Cells(5 + i, (j - 1) * 2 + 1) & vbLf & T0)
            Cells(5 + i, (j - 1) * 2 + 2) = IIf(Cells(5 + i, (j - 1) * 2 + 2) = "", T1, Cells(5 + i, (j - 1) * 2 + 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
         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)
            Cells(8, (j - 1) * 2 + 1) = IIf(Cells(8, (j - 1) * 2 + 1) = "", T0, Cells(8, (j - 1) * 2 + 1) & vbLf & T0)
            Cells(8, (j - 1) * 2 + 2) = IIf(Cells(8, (j - 1) * 2 + 2) = "", T1, Cells(8, (j - 1) * 2 + 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))
         Cells(8, (j - 1) * 2 + 1) = IIf(Cells(8, (j - 1) * 2 + 1) = "", T0, Cells(8, (j - 1) * 2 + 1) & vbLf & T0)
         Cells(8, (j - 1) * 2 + 2) = IIf(Cells(8, (j - 1) * 2 + 2) = "", T1, Cells(8, (j - 1) * 2 + 2) & vbLf & T1)
j02:    Next
   Next
   u = 8
   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
         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)
            Cells(u, (j - 1) * 2 + 1) = T0: Cells(u, (j - 1) * 2 + 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)
            Cells(u, (j - 1) * 2 + 1) = IIf(Cells(u, (j - 1) * 2 + 1) = "", T0, Cells(u, (j - 1) * 2 + 1) & vbLf & T0)
            Cells(u, (j - 1) * 2 + 2) = IIf(Cells(u, (j - 1) * 2 + 2) = "", T1, Cells(u, (j - 1) * 2 + 2) & vbLf & T1)
         Next
j03:    Next
   Next
End With: End With
M01: Next
End Sub

作者: 198188 時間: 2024-3-21 12:18

回復 14# Andy2483

我運行后，在#004卡住了，不知道哪裏出現問題。附上Excel.

另外分割第一欄位 C, E, G, I, K, M，沒有去掉 “ # ”，分割第二欄位D, F, H, J, L, N 沒有去掉 " ( " & " ) "

作者: Andy2483 時間: 2024-3-21 12:20

回復 15# 198188

謝謝前輩回復
請自己試著排除問題

作者: 198188 時間: 2024-3-21 12:30

回復 16# Andy2483

好像是中英文的）問題，實際就不知道是不是。那些有問題的儲存格改了英文的）就沒問題。

另外下面這個功能是否做不到？

分割第一欄位 C, E, G, I, K, M，沒有去掉 “ # ”，分割第二欄位D, F, H, J, L, N 沒有去掉 " ( " & " ) "

下面這些去掉 “（” & “）”
(02F单元)
(02F单元)
(9-12F门散件)
(2-7F栏杆)

下面這些去掉 “ # ”
#2312302239
#2312302236
#2312302240
#2402190275

作者: Andy2483 時間: 2024-3-21 12:53

回復 17# 198188

Sub TEST_1()
Dim T$
T = "(A(BC)D)"
If T Like "(*)" Then T = Mid(T, 2, Len(T) - 2)
MsgBox T
End Sub

作者: 198188 時間: 2024-3-21 13:46

回復 18# Andy2483

加在哪個位置上？

作者: Andy2483 時間: 2024-3-21 14:54

回復 19# 198188

方案的代碼都是VBA基礎,請試著多了解其意義,加在適當位置

作者: Andy2483 時間: 2024-3-22 08:51

本帖最後由 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

作者: 198188 時間: 2024-3-22 15:24

回復 21# Andy2483

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

[attach]37614[/attach]

作者: Andy2483 時間: 2024-3-22 16:07

回復 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 時間: 2024-3-22 16:18

回復 23# Andy2483

[attach]37615[/attach]
我每次打開第一次執行都會有這個錯誤，然後我按結束，再按一次執行，就沒有問題。
不知道是哪方面的問題？

作者: Andy2483 時間: 2024-3-22 16:45

回復 24# 198188

一樣,再研究看看

作者: Andy2483 時間: 2024-3-25 13:16

回復 24# 198188

https://forum.twbts.com/viewthread.php?tid=4942
把按鈕移到 Sheet1 試試看

作者: 198188 時間: 2024-3-25 16:27

回復 26# Andy2483

[attach]37622[/attach]
也一樣有這個問題

作者: Andy2483 時間: 2024-3-26 07:23

回復 27# 198188

Sub Map() 改為 Sub Map_1() 後,將巨集重指定,試試看

作者: 198188 時間: 2024-3-26 08:15

回復 28# Andy2483

[attach]37623[/attach]
也一樣，有這個問題。

作者: 198188 時間: 2024-4-12 17:57

回復 198188

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

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

作者: Andy2483 時間: 2024-4-16 08:55

回復 30# 198188

最近有點忙,請前輩舉出不懂的地方,後學有空會回復或請另發話題請教前輩們

作者: 198188 時間: 2024-4-16 09:59

回復 198188

最近有點忙,請前輩舉出不懂的地方,後學有空會回復或請另發話題請教前輩們
Andy2483 發表於 2024-4-16 08:55

沒事，不急，等前輩有時間在回復。
暫時是這句
If (Not A Like "[#]###") Or (IsError(D)) Or (Not Q Like "##?Q") Then MsgBox "資料不符規則1": Exit Sub

作者: Andy2483 時間: 2024-4-16 14:03

回復 32# 198188

If (Not A Like "[#]###") Or (IsError(D)) Or (Not Q Like "##?Q") Then MsgBox "資料不符規則1": Exit Sub
'↑如果A變數(字串)其字元排列順序(左至右)不是 #字元開頭連接3個數字,或D變數是錯誤值,或
'Q變數(字串)其字元排列順序(左至右)不是 2個數字開頭連接1個任意字元最後連接 Q字元,
'這3個條件其中一個成立,就跳出提視窗~~,結束程式執行,這是要檢查資料表是否規則正確

作者: quickfixer 時間: 2024-4-17 11:28

本帖最後由 quickfixer 於 2024-4-17 11:29 編輯

回復 33# Andy2483

曾經被01的高手指導過,他說少用冒號來連結程式碼,尤其是前面有if的時候
那只是看起來比較短,對速度沒幫助,可讀性也不好,有時候還會不小心出意外

Sub test()

aa = "andy2483"
bb = "andy2484"

If aa = bb Then Debug.Print "andy": Debug.Print "cc": Exit Sub

Debug.Print "dd"

End Sub

Sub test1()

aa = "andy2483"
bb = "andy2484"

If aa = bb Then Debug.Print "andy"
Debug.Print "cc"
Exit Sub

Debug.Print "dd"

End Sub

作者: jackyq 時間: 2024-4-17 20:12

冒號是個硬傷
只有幾種情況下可用
很多人都不知道
都在依樣畫葫蘆

作者: 198188 時間: 2024-4-19 17:42

本帖最後由 198188 於 2024-4-19 17:47 編輯

回復 Andy2483

曾經被01的高手指導過,他說少用冒號來連結程式碼,尤其是前面有if的時候
那只是看 ...
quickfixer 發表於 2024-4-17 11:28

謝謝前輩提醒。

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)