- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-12-18
|
6#
發表於 2021-12-8 11:32
| 只看該作者
本帖最後由 samwang 於 2021-12-8 11:33 編輯
回復 1# wsx1130
請測試看看，謝謝
1. 工單號碼/製成簡稱: 從資料庫取唯一值然後自動匯出
2. 2021/11/02 16:06_1080_2021/11/02 16:13
工單+製程: 第一筆開始時間 _ 累加數量 _ 最後完成(max)時間
Sub test()
Dim conn As New ADODB.Connection
Dim Arr, xD, Brr(), xD1, C%, n%, m%, i&, SD, ED, cnt
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
With Sheets(3)
.[a1].CurrentRegion.Offset(1) = ""
' .[a1:i1] = Array("ID", "報工序號", "工號", "班別代碼", "報工日期", "工單號碼", "作業序號", "製程簡稱", "作業細項")
' .[j1:q1] = Array("開始時間", "完成時間", "時數", "數量", "不良數量", "工單號碼", "備註", "原因代碼", "狀態")
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=D:\database-test.mdb"
.Range("a2").CopyFromRecordset conn.Execute("select * from [DailyReport43600]")
conn.Close
Arr = .[a1].CurrentRegion
End With
ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr))
For i = 2 To UBound(Arr): xD(Arr(i, 8) & "") = "": Next
With Sheets(4)
.[a1].CurrentRegion = ""
.Range("b1").Resize(1, xD.Count) = xD.keys
.[a1] = "工單號碼/製程簡稱"
For i = 2 To UBound(Arr)
C = Application.WorksheetFunction.Match(Arr(i, 8), .Range(.[b1], .Cells(1, xD.Count + 1)), 0) + 1
If xD1.Exists(Arr(i, 6) & "") Then
m = xD1(Arr(i, 6) & "")
If Brr(m, C) <> "" Then
SD = Split(Brr(m, C), "_")(0)
cnt = Split(Brr(m, C), "_")(1)
ED = Split(Brr(m, C), "_")(2)
If Arr(i, 11) > ED Then ED = Arr(i, 11)
End If
Brr(m, C) = SD & "_" & cnt + Arr(i, 13) & "_" & ED
Else
n = n + 1: xD1(Arr(i, 6) & "") = n
Brr(n, 1) = Arr(i, 6)
Brr(n, C) = Arr(i, 10) & "_" & Arr(i, 13) & "_" & Arr(i, 11)
End If
Next
.Range("a2").Resize(n, xD.Count + 1) = Brr
End With
End Sub |
-
-
33.JPG
(184.66 KB)
|
