[發問] 另存新檔，資料驗證

本帖最後由 lovenice831 於 2021-1-25 12:15 編輯

早前請教了如何把數據自動輸入表格中，因表格更新了，所以我作出了改動，但改動後便出現資料驗證的問題，連帶另存的檔案也出現這個問題，不知道是否我的改動出了問題，求指點，謝謝
This Workbook
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If ActiveSheet.Name <> "Receiving Report" Then Exit Sub
With Target
   If .Address = "$J$6" Then Call ¸ü¤J¸ê®Æ
End With
End Sub
Module
Sub «¸m²M³æ()
Dim xS As Worksheet, Arr, xD, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xS = Sheets("Receiving DATA")
Arr = Range(xS.[M1], xS.[M65536].End(xlUp)(4))
For i = 5 To UBound(Arr)
If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "") = ""
Next i
With ['Receiving Report'!J6]
.Value = ""
.Validation.Delete
If xD.Count = 0 Then Exit Sub
.Validation.Add Type:=xlValidateList, Formula1:=Join(xD.keys, ",")
End With
End Sub

Sub ²MªÅªí®æ()
Application.ScreenUpdating = False
With Sheets("Receiving Report")
   .Range("J8,C11:C12,F11,J11:J12,G12,G14:H14") = ""
   R& = .[A60000].End(xlUp).Row
   If R > 24 Then .Range("A22:A" & R - 3).EntireRow.Delete
   .Range("A20:H22") = ""
End With
End Sub

Sub ¸ü¤J¸ê®Æ()
Dim xS As Worksheet, Arr, Brr, i&, j%, T$, R&, N&
Call ²MªÅªí®æ
T = [J6]:  If T = "" Then Exit Sub
Set xS = Sheets("Receiving DATA")
R = xS.[M65536].End(xlUp).Row
Arr = xS.Range("A1:P" & R)
ReDim Brr(1 To 2000, 1 To 9)
For i = 5 To R
If Arr(i, 13) & "" <> T Then GoTo 101
N = N + 1
If N = 1 Then
   [J8] = Arr(i, 5) 'Lot Number
   [C11] = Int(Arr(i, 2)): [F11] = TimeValue(Arr(i, 2)) '¦¬³f¤é´Á + ¦¬³f®É¶¡
   [C12] = Arr(i, 3): [J11] = Arr(i, 11) 'Âd¸¹/³f¨®¨®µP + PO No.
   [G12] = Arr(i, 4): [J12] = Arr(i, 14) '«Ê±ø¸¹ + BDt³d¤H

End If
For j = 0 To 4: Brr(N, Array(1, 3, 4, 5, 8)(j)) = Arr(i, Array(9, 5, 7, 8, 10)(j)): Next
101: Next i
If N = 0 Then MsgBox "¨S¦³²Å¦X¸ê®Æ": Exit Sub
If N > 3 Then

Range("A22").Resize(N - 3).EntireRow.Insert
Range("A21:K21").Copy Range("A22").Resize(N - 3)
End If
Range("A20:H20").Resize(N) = Brr
[G14] = WorksheetFunction.Subtotal(3, [D20].Resize(N))
[H14] = WorksheetFunction.Sum([E20].Resize(N))
End Sub

Sub Save()
Dim R&, xS As Worksheet, xName$, xB As Workbook
Set xS = Sheets("Receiving Report")
xName = ThisWorkbook.Path & "\Receiving Report" & "_" & xS.[J8] & ".xlsx" 'save new file name
Application.ScreenUpdating = False
xS.Copy 'copy this sheets to a new sheets
Set xB = ActiveWorkbook
With xB.Sheets(1)
      For Each sp In ActiveSheet.Shapes
  If sp.Name Like "*Button*" Then sp.Delete
  Next
End With
Application.DisplayAlerts = False 'if save name is here not warnning to save new file
xB.SaveAs xName, CreateBackup:=False 'save as
xB.Close 0
MsgBox "~~save complate~~ "
End Sub