- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-3-24
|
本帖最後由 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 |
|
發表於 2024-3-22 08:51
| 
