[發問] 如何按鈕合併與增加程式

BV7BW

請教 各位 先進 前輩 老師們

如何按鈕合併與增加程式

問題1)"綜合輸入"與"單車輸入"是否可合併成1單獨按鈕
以"採購需求表""A1"為判別資料
如:A車"就需用"單車戴入"按紐執行
如何辦別"A1"為"綜合"時就需以"綜合戴入"按鈕執行

問題2)戴入資料前先清除框線.戴入後以"A1"至最後1筆資料劃上框線

問題3)"採購需求表""A1"是否可複製至"客戶配送表"A1"中增列進去
現以=IF(採購需求表!A1="","",採購需求表!A1)  使用
是否可一併在程式中

需求1)如何辦別"A1"為"綜合"時就需以"綜合戴入"按鈕執行
需求2)戴入資料前先清除框線.戴入後以"A1"至最後1筆資料劃上框線
需求3)原程式中增列"採購需求表""A1"複製至"客戶配送表"A1"中
   謝謝各位 先進 前輩 老師們 指導
活頁簿1.zip (66.09 KB)

下載次數: 1

2021-8-7 10:36

singo1232001

回復 1# BV7BW

BV7BW

回復 2# singo1232001

感謝 singo1232001 大大 指導

問題1.3)以singo1232001 大大阪修改後合俯需求

問題2)也修改一半完成.
另一半是由程式判斷最後一筆資料後劃上框線

Sub 綜合_載入_先導程序()
'程式資料來源至singo1232001-110-08-08版
[客戶配送表!a1] = [採購需求表!a1] '新增
Call 清除框線  '新增
If [採購需求表!a1] = "綜合" Then Call 採購需求客戶配送_綜合
If [採購需求表!a1] <> "綜合" Then Call 採購需求客戶配送_載入
End Sub
Sub 清除框線() '錄製巨集的
    Set Rng = [採購需求表!a2:c100]
    Rng.Borders(xlDiagonalDown).LineStyle = xlNone
    Rng.Borders(xlDiagonalUp).LineStyle = xlNone
    Rng.Borders(xlEdgeLeft).LineStyle = xlNone
    With Rng.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Rng.Borders(xlEdgeBottom).LineStyle = xlNone
    Rng.Borders(xlEdgeRight).LineStyle = xlNone
    Rng.Borders(xlInsideVertical).LineStyle = xlNone
    Rng.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub



Sub 採購需求客戶配送_載入()

'[客戶配送表!a1] = [採購需求表!a1] ''''''''''''''''''''''''''''
'程式資料來源至准提部林_出貨作業D版V01_10905
Dim Arr, Brr, Crr, xD, N&, i&, T$, U&, DD, CC$
[採購需求表!A2:C500].ClearContents
[客戶配送表!A2:C500].ClearContents

DD = [C1]: CC = [A1]
If Not IsDate(DD) Then MsgBox "**請輸入日期!!  ": Exit Sub
If CC = "" Then MsgBox "**請輸入[車編]!!  ": Exit Sub
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([訂貨明細表!L1], [訂貨明細表!A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 3): Crr = Brr
For i = 2 To UBound(Arr)
    If Arr(i, 12) <> DD Or Arr(i, 10) <> CC Then GoTo 101 '比對日期&車編
    T = Arr(i, 3):  U = xD(T)
    If U = 0 Then N = N + 1: U = N: xD(T) = N
    Brr(U, 1) = Arr(i, 9) '類別
    'Brr(U, 2) = "'" & Arr(i, 11) '項目編號
    Brr(U, 2) = Arr(i, 4) '項目名稱
    Brr(U, 3) = Brr(U, 3) & IIf(Brr(U, 3) = "", "", " + ") & Arr(i, 5) & "*" & Arr(i, 6)
    '---------------------------------
    Crr(U, 1) = Arr(i, 9) '類別
    'Crr(U, 2) = "'" & Arr(i, 11) '項目編號
    Crr(U, 2) = Arr(i, 4) '項目名稱
    Crr(U, 3) = Crr(U, 3) & IIf(Crr(U, 3) = "", "", " + ") & Arr(i, 2) & "*" & Arr(i, 5) & Arr(i, 6)  '加客戶編
101: Next i
If N = 0 Then MsgBox "**沒有符合指定日期資料!!  ": Exit Sub
Application.ScreenUpdating = False

With [客戶配送表!A2].Resize(N, 3)
     .Parent.[C1] = DD
     .Value = Crr
     .Sort Key1:=.Item(1), Order1:=xlAscending, _
           Key2:=.Item(2), Order2:=xlAscending, Header:=xlNo
    For i = N + 1 To 2 Step -1
         If .Cells(i, 1) <> .Cells(i - 1, 1) Then
            .Cells(i, 1).Resize(1, 3).Insert Shift:=xlDown
         End If
     Next i
End With
With [採購需求表!A2].Resize(N, 3)
     .Parent.[C1] = DD
     .Value = Brr
     .Sort Key1:=.Item(1), Order1:=xlAscending, _
           Key2:=.Item(2), Order2:=xlAscending, Header:=xlNo
     For i = N + 1 To 2 Step -1
         If .Cells(i, 1) <> .Cells(i - 1, 1) Then
            .Cells(i, 1).Resize(1, 3).Insert Shift:=xlDown
         End If
     Next i
End With
End Sub

Sub 採購需求客戶配送_綜合()
'程式資料來源至准提部林_出貨作業D版V01_10905
Dim Arr, Brr, Crr, xD, N&, i&, T$, U&, DD
[採購需求表!A2:C500].ClearContents
[客戶配送表!A2:C500].ClearContents
DD = [C1]
If Not IsDate(DD) Then MsgBox "**請輸入日期!!  ": Exit Sub
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([訂貨明細表!L1], [訂貨明細表!A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 3): Crr = Brr
For i = 2 To UBound(Arr)
    If Arr(i, 12) <> DD Then GoTo 101 '比對日期
    T = Arr(i, 3):  U = xD(T)
    If U = 0 Then N = N + 1: U = N: xD(T) = N
    Brr(U, 1) = Arr(i, 9) '類別
    'Brr(U, 2) = "'" & Arr(i, 11) '項目編號
    Brr(U, 2) = Arr(i, 4) '項目名稱
    Brr(U, 3) = Brr(U, 3) & IIf(Brr(U, 3) = "", "", " + ") & Arr(i, 5) & "*" & Arr(i, 6)
    '---------------------------------
    Crr(U, 1) = Arr(i, 9) '類別
    'Crr(U, 2) = "'" & Arr(i, 11) '項目編號
    Crr(U, 2) = Arr(i, 4) '項目名稱
    Crr(U, 3) = Crr(U, 3) & IIf(Crr(U, 3) = "", "", " + ") & Arr(i, 2) & "*" & Arr(i, 5) & Arr(i, 6)  '加客戶編
101: Next i
If N = 0 Then MsgBox "**沒有符合指定日期資料!!  ": Exit Sub
Application.ScreenUpdating = False

With [客戶配送表!A2].Resize(N, 3)
     .Parent.[C1] = DD
     .Value = Crr
     .Sort Key1:=.Item(1), Order1:=xlAscending, _
           Key2:=.Item(2), Order2:=xlAscending, Header:=xlNo
    For i = N + 1 To 2 Step -1
         If .Cells(i, 1) <> .Cells(i - 1, 1) Then
            .Cells(i, 1).Resize(1, 3).Insert Shift:=xlDown
         End If
     Next i
End With
With [採購需求表!A2].Resize(N, 3)
     .Parent.[C1] = DD
     .Value = Brr
     .Sort Key1:=.Item(1), Order1:=xlAscending, _
           Key2:=.Item(2), Order2:=xlAscending, Header:=xlNo
     For i = N + 1 To 2 Step -1
         If .Cells(i, 1) <> .Cells(i - 1, 1) Then
            .Cells(i, 1).Resize(1, 3).Insert Shift:=xlDown
         End If
     Next i
End With
End Sub

謝謝 singo1232001 大大

BV7BW

活頁簿1singo1232001版.zip (65.8 KB)

下載次數: 0

2021-8-8 05:38

回復 3# BV7BW

BV7BW

回復 4# BV7BW
更正檔案. 活頁簿1singo1232001版.zip (65.95 KB)

下載次數: 2

2021-8-9 18:02