- 帖子
- 406
- 主題
- 8
- 精華
- 0
- 積分
- 453
- 點名
- 0
- 作業系統
- WINDOWS 7
- 軟體版本
- 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2015-2-7
- 最後登錄
- 2021-7-31
|
本帖最後由 n7822123 於 2021-1-5 03:06 編輯
回復 17# n7822123
發現我的程式Bug，當該報告編號的資料剛好只有一筆時，會有問題(陣列轉置會變成1維陣列)
修改如下程式，這次應該可以滿足你的需求~ 功能如下
點選 報告頁的 J6 儲存格 ，會自動依 Data頁 的 "Receiving Report No" 產生下拉式選單
選擇好 "Reference No" (J6)後，會自動產生報告(另做新工作表，不改範本格式，避免重複執行會有問題)
觸發事件-自動觸發程式，請複製貼上到 "Receiving Report" 工作表裡面
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row = 6 And Target.Column = 10 Then
Application.EnableEvents = False
Call 設下拉選單
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 6 And Target.Column = 10 Then
Application.EnableEvents = False
Call 收貨報表_單選
Application.EnableEvents = True
End If
End Sub
一般模組程式，請隨便創一個模組貼上程式即可
Dim Arr, RepNo$
Sub 設下拉選單()
Application.ScreenUpdating = False
On Error GoTo 恢復
Set D = CreateObject("Scripting.Dictionary")
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
RepNo = Arr(R, 13)
If D(RepNo) = 0 Then D(RepNo) = R
Next R
For Each Key In D.keys: 批號串 = 批號串 & "," & Key: Next Key
With ['Receiving Report'!J6].Validation
.Delete
.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=批號串
End With
Exit Sub
恢復: 開啟觸發事件
End Sub
Sub 收貨報表_單選()
Dim Brr(), R0%, R&, K%, D As Object
Application.ScreenUpdating = False
On Error GoTo 恢復
RepNo = ['Receiving Report'!J6]
If RepNo = "" Then Exit Sub
Set D = CreateObject("Scripting.Dictionary")
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
If D(Arr(R, 13) & "") = 0 Then D(Arr(R, 13) & "") = R
Next R
R0 = D(RepNo): 新表 R0
For R = R0 To UBound(Arr)
K = K + 1: ReDim Preserve Brr(1 To 11, 1 To K)
Brr(1, K) = Arr(R, 9) '貨物名稱
Brr(3, K) = Arr(R, 5) '批號
Brr(4, K) = Arr(R, 7) '板號
Brr(5, K) = Arr(R, 8) '箱號
Brr(8, K) = Arr(R, 10) '實物收貨
If R + 1 > UBound(Arr) Then 另存新檔 Brr: Exit For
If Arr(R + 1, 13) <> RepNo Then 另存新檔 Brr: Exit For
Next R: Erase Arr: Erase Brr
Exit Sub
恢復: 開啟觸發事件
End Sub
Sub 收貨報表_批次()
Dim Brr(), R&, K%
Application.ScreenUpdating = False
Arr = ['Receiving DATA'!A4].CurrentRegion
For R = 2 To UBound(Arr)
If Arr(R, 13) <> RepNo Then 新表 R: RepNo = Arr(R, 13): K = 0
K = K + 1: ReDim Preserve Brr(1 To 11, 1 To K)
Brr(1, K) = Arr(R, 9) '貨物名稱
Brr(3, K) = LotNo '批號
Brr(4, K) = Arr(R, 7) '板號
Brr(5, K) = Arr(R, 8) '箱號
Brr(8, K) = Arr(R, 10) '實物收貨
If R + 1 > UBound(Arr) Then 另存新檔 Brr: Exit For
If Arr(R + 1, 13) <> RepNo Then 另存新檔 Brr
Next R: Erase Arr: Erase Brr
Sheets("Receiving DATA").Activate
End Sub
Sub 新表(ByVal R)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Receiving Report").Copy After:=Sheets(Sheets.Count)
On Error Resume Next
Sheets("Reference No " & Arr(R, 13)).Delete
On Error GoTo 0
ActiveSheet.Name = "Reference No " & Arr(R, 13)
[C10] = Int(Arr(R, 2)) '收貨日期
[F10] = Arr(R, 2) - [C10] '收貨時間
[C11] = Arr(R, 3) '櫃號/貨車車牌
[J6] = Arr(R, 13) 'Reference No:
[J8] = Arr(R, 5) 'Lot Number
[J10] = Arr(R, 11) 'PO No.
[J11] = Arr(R, 14) 'BD 負責人
[G11] = Arr(R, 4) '封條號
刪除新表觸發事件 ActiveSheet.CodeName
[J6].Validation.Delete
End Sub
Sub 另存新檔(ByVal Brr)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path & "\"
Brr = Application.Transpose(Brr) '當Brr資料只有一筆，轉置後變1維陣列
Rn = UBound(Brr): [G13] = Rn
On Error Resume Next
XX% = UBound(Brr, 2) '當Brr=1維陣列，會跳錯誤
If Err <> 0 Then Rn = 1 '錯誤時，設Rn=1
On Error GoTo 0
If Rn >= 4 Then
Rows("21:" & 21 + Rn - 4).Insert Shift:=4
Rows(20).Copy
Rows("21:" & 21 + Rn - 4).Select
ActiveSheet.Paste
End If: [A10].Select
Application.CutCopyMode = False
[A19].Resize(Rn, 11) = Brr
[H13] = WorksheetFunction.Sum([E19].Resize(Rn))
ActiveSheet.Copy
With ActiveSheet
.Parent.SaveAs MyPath & .Name & ".xls", xlNormal
.Parent.Close 1
End With
'ActiveSheet.Delete
End Sub
Sub 刪除新表觸發事件(ByVal 新表CodeNm)
Application.DisplayAlerts = False
With ThisWorkbook.VBProject
For Each vbx In .VBComponents
If vbx.Name = 新表CodeNm Then
With vbx.CodeModule: .DeleteLines 1, .CountOfLines: End With
End If
Next
End With
End Sub
Sub 開啟觸發事件()
Application.EnableEvents = True
End Sub
檔案如下
 test Receiving Data 2021-0105.rar (55.67 KB)
|
|
發表於 2020-12-30 09:52
| 