返回列表 上一主題 發帖

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

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

本帖最後由 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) '«Ê±¸¹ + BD­t³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
0125_Receiving Data.zip (155.78 KB) Receiving Report_BAD-211034.zip (58.23 KB)
001.jpg
2021-1-25 12:12
002.jpg
2021-1-25 12:13

1) 清單文字超過限制而發生錯誤, 改用清單來源位址
2) M欄用來存放清單, 可隱藏
3) 另存新檔時, J6下拉清單驗證應清除(已沒使用意義)
0125_Receiving Data-1.rar (149.58 KB)

TOP

回復 2# 准提部林


    謝謝大大的指導,我還有一個問題,怎樣才能在另存新檔時把下拉清單清除呢?  謝謝

TOP

回復 3# lovenice831


樓上附檔中就有刪除下拉清單指令~~

TOP

回復 4# 准提部林


    謝謝大大 ,十分感謝

TOP

        靜思自在 : 做好事不能少我一人,做壞事不能多我一人。
返回列表 上一主題