- 帖子
- 1429
- 主題
- 40
- 精華
- 0
- 積分
- 1453
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-5-18
|
2#
發表於 2023-4-25 16:45
| 只看該作者
回復 1# PJChen
謝謝前輩發表此主題與範例
後學學習方案如下,請前輩參考
Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, i&, j&, R, T, Td$, Tn$, G1$
Dim xR As Range, xU As Range, Sh As Worksheet, MyBook, MyPath
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("裝櫃通知")
Set R = Sh.[D:D].Find("TOTAL", Lookat:=xlWhole)
If Not R Is Nothing Then R = R.Row
Brr = Range(Sh.[A7], Sh.Cells(R - 1, "H"))
For i = 1 To UBound(Brr)
If Brr(i, 1) = "" Then
For j = 1 To 8: T = T & Trim(Brr(i, j)): Next
If T <> "" Then Brr(i, 1) = Brr(i - 1, 1) Else: GoTo i01
End If
Y(Brr(i, 1)) = Y(Brr(i, 1)) + 1
If Y(Brr(i, 1) & "|c") = "" Then Y(Brr(i, 1) & "|c") = Brr(i, 3)
i01: T = "": Next
If Y.Count = 0 Then Exit Sub
G1 = Sh.[G1].Text & Sh.[E1] & "-" & Replace(Replace(Sh.[G2], "/", ""), "#", "") & Sh.[H2]
Td = Format(Now, "YYYY_MM_DD_HH_MM_SS")
Set MyBook = ThisWorkbook
MyPath = MyBook.Path & "\"
If Dir(MyPath & Td, vbDirectory) = "" Then MkDir MyPath & Td
For Each T In Y.KEYS
If InStr(T, "|") Then GoTo i02
Sheets("裝櫃通知").Copy
Set xU = Cells(Rows.Count, 1).Resize(1, 8)
For i = 1 To UBound(Brr)
If Brr(i, 1) <> T Then
Set xU = Union(Cells(i + 6, 1).Resize(1, 8), xU)
End If
Next
xU.Delete: [A7] = 1
Tn = Y(T & "|c") & "-" & G1 & ".xlsx"
ActiveWorkbook.SaveAs Filename:=MyPath & Td & "\" & Tn, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
i02: Next
[A7].Resize(UBound(Brr), 8) = Brr
Set Y = Nothing: Set Sh = Nothing: Erase Brr
End Sub |
|
