- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-12-5
|
38#
發表於 2024-1-3 13:58
| 只看該作者
回復 36# 198188
Option Explicit
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$, S%
For i = Worksheets.Count To 4 Step -1: Worksheets(i).Delete: Next
Set Z = CreateObject("Scripting.Dictionary")
Brr = Sheets(3).UsedRange
For i = 1 To UBound(Brr): Z(Trim(Brr(i, 1))) = Trim(Brr(i, 2)): Next: S = Z.Count
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 Else Sheets(2).Copy After:=Worksheets(Sheets.Count)
ActiveSheet.Name = A '"Result " & A
[A1].Resize(UBound(Z(A)), UBound(Z(A), 2)) = Z(A)
For i = 0 To S - 1: ActiveSheet.UsedRange.Replace Z.KEYS()(i), Z.ITEMS()(i), Lookat:=xlPart: Next
A01: Next
Application.Goto Sheets(1).[A1]
End Sub |
|
