准提部林

藍色部份是修改或新增的部份!!!

Sub 客戶訂購表_輸出()
Dim R&, CN&, Arr, Brr, Crr, Drr, QQ, i&, j%, N&, xE As Range, X%, Mch, xNum&, pNo$
R = [F65536].End(xlUp).Row
CN = Application.Count(Range("G4:G" & R))
If CN = 0 Then MsgBox "**尚未輸入數量!  ": Exit Sub
If [a2] = "" Then MsgBox "**尚未輸入客戶名稱!  ": Exit Sub
If Not IsDate([A4]) Then MsgBox "**日期空白或錯誤! ": Exit Sub
'------------------------------------
xNum = [o2] '單號
If Not xNum Like String(10, "#") Then MsgBox "**單號錯誤或空白! ": Exit Sub
If Left(xNum, 7) <> Year([A4]) - 1911 & Format([A4], "mmdd") Then MsgBox "**單號前７碼與日期不相符! ": Exit Sub
'///2021.07.13增修////////////////////////////
Mch = Application.Match(xNum, [訂貨明細表!J:J], 0) '檢查單號是否已存在
If [n5] <> "修改中" Then
   If IsNumeric(Mch) Then MsgBox "**單號已存在! ": Exit Sub
   NM = [a2] '客戶
   DD = [A4] '日期
   Mch = Application.Match(CLng(DD), [訂貨明細表!k:k], 0)  '先檢查日期是否存在
   If IsNumeric(Mch) Then
       Arr = Range([訂貨明細表!m1], [訂貨明細表!a1].Cells(Rows.Count, 1).End(xlUp))
       For i = Mch To UBound(Arr)
           If Arr(i, 11) <> DD Then Exit For
           If Arr(i, 11) = DD And Arr(i, 1) = NM Then '日期相同+客戶相同
              MsgBox "※日期:" & DD & "，客戶:" & NM & "已經有資料!   " & vbCrLf & _
                     "　若想新增舊訂單的內容，請使用〔修改輸入〕按鈕！　"
              Exit Sub
           End If
       Next i
   End If
End If
'////////////////////////////////////////////////
'-----------------------------------------------
pNo = [a8].Text
If UCase(Right([M2], 1)) = "S" And pNo = "" Then
   MsgBox "**【客戶編號：" & [M2] & "】結尾有""S"", 必須輸入【採購單號】,   " & vbCrLf & vbCrLf & _
          "若沒有【採購單號】,或暫時不輸入, 請輸入0!"
   [a8].Select: Exit Sub
End If
If pNo = "N/A" Then pNo = ""
'-----------------------------------------------
Arr = Range("D4:J" & R)
ReDim Crr(1 To CN, 1 To 13)
For i = 1 To UBound(Arr)
    If Val(Arr(i, 4)) <= 0 Then GoTo 101
    N = N + 1
    '(1)客戶(2)客戶編號(3)項目編號(4)項目名稱(5)數量(6)單價(7)金額(8)類別(9)車編(10)單號(11)日期(12)合計金額(13)採購單號
    QQ = Array([a2], [M2], Arr(i, 1), Arr(i, 2), Arr(i, 4), Arr(i, 5), "=N(RC[-2])*N(RC[-1])", Arr(i, 7), [M4], xNum, [A4], Val([O7]), pNo)
    For j = 0 To UBound(QQ)
        Crr(N, j + 1) = QQ(j)
    Next j
101: Next i
If N = 0 Then Exit Sub
'-------------------------------------
'＝2021.07.10增修＝＝＝＝＝＝＝＝＝＝＝
With Sheets("訂貨明細表")
     With .[A65536].End(xlUp)(2).Resize(N, UBound(Crr, 2))
          .Value = Crr
           If [n5] = "修改中" Then .Interior.ColorIndex = 35 '若屬修改..填淡綠色
     End With
     Range(.[m1], .[A65536].End(xlUp)).Sort Key1:=.[j1], Order1:=xlAscending, Header:=xlYes
End With
If [n5] = "修改中" Then
   [o2].Formula = "=IF(A4="""","""",IF(ISNA(MATCH(A4,訂貨明細表!K:K,)),TEXT(A4,""emmdd"")*1000,LOOKUP(TEXT(A4+1,""emmdd"")*1000,訂貨明細表!J:J))+1)"
   [n5] = "待命中"
End If
'=======================================
'-------------------------------------
ChangeChk = 1: [送貨單!B2] = xNum
Call 送貨單_載入: ChangeChk = 0
'----------------------------------------
Range("G4:G" & R).ClearContents: [a2] = "": [a8] = "" '清除:數量/客戶/採購單號, 供下次輸入
If MsgBox("※輸出完成, 是否要立即跳至[送貨單]??  ", 4 + 32 + 256) = vbYes Then Application.Goto [送貨單!A7]
End Sub


'*********************************************

准提部林

藍色部份是修改或新增的部份!!!  

Sub 客戶訂購表_重置()
Dim R&
If MsgBox("※確定要重置輔助公式及清除輸入數量嗎?  ", 4 + 32 + 256) = vbNo Then Exit Sub
R = [B65536].End(xlUp).Row
Range("G3:G" & R).ClearContents
Call 客戶訂購表_輔助公式
'＝2021.07.10增修＝＝＝＝＝＝＝＝＝＝＝
[o2].Formula = "=IF(A4="""","""",IF(ISNA(MATCH(A4,訂貨明細表!K:K,)),TEXT(A4,""emmdd"")*1000,LOOKUP(TEXT(A4+1,""emmdd"")*1000,訂貨明細表!J:J))+1)"
[n5] = "待命中"
'======================================
End Sub

准提部林

回復 26# BV7BW

邏輯跟不上, 整個都混了....
回到原點:
輸出時--檢查同一日是否有相同的客戶,
若有...提示訊息..按"否"-不動作結束...按"是"-以新單號輸出至明細表
出貨作業D版v01_1100725.rar (377.44 KB)

下載次數: 4

2021-7-25 10:26

同一日, 客戶有新追加者, 都以新單號處理, 不再用舊單號作增補了!!!

准提部林

回復 28# BV7BW

If Arr(i, 11) = DD And Arr(i, 1) = NM Then '日期相同+客戶相同
    Beep '若存在, 發出嗶聲, 並提示是否進行補增???
    If MsgBox("※日期：" & DD & "，客戶：" & NM & "，單號：" & Arr(i, 10) & "，已經有資料！   " & vbCrLf & vbCrLf & _
          "，你要繼續輸入本張訂單嗎?  ", 4 + 32 + 256) = vbNo Then Exit Sub  '按"否"結束
    Exit For  '加這一行
End If