- 帖子
- 1567
- 主題
- 40
- 精華
- 0
- 積分
- 1591
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2026-2-2
|
21#
發表於 2023-12-30 14:51
| 只看該作者
本帖最後由 Andy2483 於 2023-12-30 14:53 編輯
回復 20# 198188
謝謝前輩再回復新範例,以下是學習的方案,請前輩參考
Option Explicit
Sub TEST()
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 3 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 = Left(A(0), 8): 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 = "Result " & A
[A1].Resize(UBound(Z(A)), UBound(Z(A), 2)) = Z(A)
End With
A01: Next
Application.Goto Sheets(1).[A1]
End Sub |
|
