n7822123

回復 9# lovenice831

DATA 的資料會增加而每增加一個我便需要在REPORT 表中填寫對的資料，
再把REPORT 另存新檔上傳回公司系統，而REPORT 是用Reference No:來紀錄及命名，
會否有語法可以在REPORT 頁中簡選 Reference No:，便能從DATE 中自動找出對應資顯示在REPORT 中?
我在網上找的多是用於同一分頁及表格都是單一對應的例子，這份表格的確是麻煩了些，先謝謝你的幫忙，謝謝

我做了個 彈出表單 用 ListBox 讓你選，但是做了表單，只貼程式就沒意義了!

你需要下載我的附件才能看到那個表單，如果你還是不能下載附件，我只能用 Inputbox 列出來讓你選了.......

準大的疑惑，我也是有的，那些CheckBox 我都沒去改喔，都是原本的值

有需要，再提供判斷規則讓VBA去填，檔案如下

test Receiving Data 2021-0101.rar (73.79 KB)

下載次數: 4

2021-1-1 13:54

n7822123

回復 11# n7822123

上樓的檔案，右上"X"的關閉表單邏輯有些問題

請用下面此檔


test Receiving Data 2021-0101(NEW).rar (69.7 KB)

下載次數: 5

2021-1-1 14:05

lovenice831

回復 10# 准提部林


   不用，那些都不用選的，所以不用動那幾個儲存格

lovenice831

回復 12# n7822123


    謝謝

lovenice831

我試著用 REPORT 中的 J6 格改成下拉清單，範圍是報表的上半部份，看網上短片範例當改變清單後資料會自動跳出相應資料，但語法不知出了什麼問題，不會自己跳轉，有朋友能幫忙看看嗎?

test Receiving Data 0104.rar (83.4 KB)

下載次數: 6

2021-1-4 09:22

n7822123

回復 15# lovenice831

程式比對分大小寫

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$J$6" Then
        Call Update
    End If
End Sub

n7822123

回復 15# lovenice831


原來你的 "Reference No:"  是指 Data頁的 "Receiving Report No."

我大概知道你要幹嘛了，用我之前的檔案改給你

點選 報告頁的 [J6] 自動依 Data頁 的 Receiving Report No 產生下拉式選單

選擇好 "Reference No" 後，自動產生報告(另做新工作表，不改範本格式，避免重複執行會有問題)

同路徑下也會產生該報告的檔案 ，先貼程式如下


觸發事件-自動觸發程式，請複製貼上到 "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 恢復
Arr = ['Receiving DATA'!A4].CurrentRegion
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
RepNo = ['Receiving Report'!J6]
If RepNo = "" Then Exit Sub
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, 5) <> LotNo Then 另存新檔 Brr: Exit For
Next R: Erase Arr: Erase Brr
A = 10 / 0
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, 5) <> LotNo Then 新表 R: LotNo = Arr(R, 5): 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, 5) <> LotNo 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
End Sub

Sub 另存新檔(ByVal Brr)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path & "\"
Brr = Application.Transpose(Brr)
Rn = UBound(Brr): [G13] = Rn
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-0104(New).rar (54.08 KB)

下載次數: 2

2021-1-5 01:54

n7822123

回復 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)

下載次數: 4

2021-1-5 02:59

n7822123

回復 15# lovenice831


暈頭了，真的很粗心....，收貨板數沒改到，改一下程式位置

Rn = UBound(Brr)
On Error Resume Next
XX% = UBound(Brr, 2)   '當Brr=1維陣列，會跳錯誤
If Err <> 0 Then Rn = 1  '錯誤時，設Rn=1
On Error GoTo 0
[G13] = Rn

檔案如下

test Receiving Data 2021-0105-NEW.rar (55.78 KB)

下載次數: 21

2021-1-5 03:18

lovenice831

回復 19# n7822123


看到報表十分激動，真的很謝謝你 {:3_59:} {:3_59:}