請求改良程式：
下面程式有下面問題：
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 |
發表於 2024-3-13 18:10
| 
