- 帖子
- 199
- 主題
- 22
- 精華
- 0
- 積分
- 233
- 點名
- 230
- 作業系統
- Vista
- 軟體版本
- Office2003
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 高雄
- 註冊時間
- 2020-4-14
- 最後登錄
- 2024-11-28
   
|
3#
發表於 2021-8-8 05:36
| 只看該作者
回復 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 大大 |
|
