- 帖子
- 2834
- 主題
- 10
- 精華
- 0
- 積分
- 2890
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-11-26
|
3#
發表於 2019-7-13 11:28
| 只看該作者
採逐筆寫入, 速度較慢:
Sub TEST()
Dim Sht As Worksheet, Arr, xD, i&, j%, T1$, T2$, U1&, U2&
Set Sht = ActiveSheet
Call 刪除分類工作表
Application.ScreenUpdating = False
Arr = Range([A1], Cells(Rows.Count, 1).End(xlUp))
Set xD = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
T1 = Split(Arr(i, 1), "-")(0): T2 = ""
For j = 1 To Len(T1)
If IsNumeric(Mid(T1, j, 1)) Then T2 = Left(T1, j - 1): Exit For
Next j
If T2 = "" Then GoTo 101
If xD(T2) = 0 Then '建立新分類工作表
Sheets.Add(after:=Sheets(Sheets.Count)).Name = T2: Sht.Select: xD(T2) = 1
Sheets(T2).[A1:E1] = Array("編號", "數量", "", "總數量", "=sum(B:B)")
End If
U1 = xD(T1 & "-V"): U2 = xD(T2)
If U1 = 0 Then U2 = U2 + 1: U1 = U2: Sheets(T2).Cells(U1, 1) = T1 '新增編號
Sheets(T2).Cells(U1, 2) = Sheets(T2).Cells(U1, 2) + 1 '累計數量
xD(T1 & "-V") = U1: xD(T2) = U2 'U1-[編號]的[列位置], U2-[工作表]最後一筆[列數]
101: Next i
End Sub
Sub 刪除分類工作表()
Dim Sht As Worksheet
Application.DisplayAlerts = False
For Each Sht In Sheets
If Sht.Name <> ActiveSheet.Name Then Sht.Delete
Next
End Sub
 Xl0000410.rar (24.38 KB)
=============================== |
|
發表於 2019-7-11 22:48
| 
