- 帖子
- 1425
- 主題
- 40
- 精華
- 0
- 積分
- 1449
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-4-16
|
14#
發表於 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 |
|
