早前請教了如何把數據自動輸入表格中，因表格更新了，所以我作出了改動，但改動後便出現資料驗證的問題，連帶另存的檔案也出現這個問題，不知道是否我的改動出了問題，求指點，謝謝
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
[attach]32999[/attach][attach]33000[/attach][attach]33001[/attach][attach]33002[/attach]作者: 准提部林 時間: 2021-2-10 10:52
