- ©«¤l
- 1446
- ¥DÃD
- 40
- ºëµØ
- 0
- ¿n¤À
- 1470
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Excel 2010 & 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2020-7-15
- ³Ì«áµn¿ý
- 2024-10-21
|
¦^´_ 7# 198188
ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ßVBA,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò
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 "¸ê®Æ¤£²Å³W«h1": 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 "¸ê®Æ¤£²Å³W«h2": 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 "¸ê®Æ¤£²Å³W«h3": 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 "¸ê®Æ¤£²Å³W«h4": 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 |
|