[發問] 自動套表

PJChen

Dear,
我不知道這個套表問題能否用函數解決,但因為表格中的資料大多用函數套出來的,所以在這裡發問...    自動套表.rar (34.84 KB)

下載次數: 13

2019-11-5 19:00

        出貨sheet是一個每天出貨用的表格,所以資料是變動的
        因為檔案很大,我把與補貨明細無關的資料都Delete,避免干擾
        每天的缺貨都需要這張報表去發給補貨的單位
        除了表頭1:2外,這張報表每天初始都是空白的
        我要把出貨sheet的資料套進來,請教用函數比較好做,還是VBA?
       
        出貨sheet要套過來的貨料:
1..        有缺貨的部份，依序從AS:BH帶資料
2..        我先做一個2個範例"林口" & "暖暖1"
3..        現在無法達成的部份在於
        要如何讓有缺貨的AS:BH的表頭自動帶到這裡的B欄?但無缺貨的自動跳過！
        並且讓缺貨的料號自動帶到A欄?
4..        第2筆缺貨的表頭 "暖暖1"帶入B欄,料號自動帶到A欄後
        如何讓E欄的公式以暖暖1為對象?而不用各別修改公式?
例：        =SUMPRODUCT((出貨!$F$4:$F$12=$A7)*(出貨!$AS$3:$BH$3=B$6)*(出貨!$AS$4:$BH$12))
        如何讓(出貨!$AS$3:$BH$3自動搜尋B$6),而不用各別改?

Andy2483

回復 31# 准提部林
謝謝前輩
後學用兩個陣列+兩個字典處理,請前輩再指導!

Option Explicit
Sub TEST_20221028()
Dim Arr, Brr, i&, j&, X, Y, C, R
R = [飛比!HE65536].End(xlUp).Row
Arr = Sheets("飛比").Range("F1:F" & R)
Brr = Sheets("飛比").Range("HD1:HE" & R)
Set X = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
For i = 4 To R
   If Val(Brr(i, 1)) > 0 Then
      X(Brr(i, 1) & "|" & i) = Arr(i, 1)
   End If
   If Val(Brr(i, 2)) > 0 Then
      Y(Brr(i, 2) & "|" & i) = Arr(i, 1)
   End If
Next
With Sheets("最後效期")
   .[J4:K4].Resize(R).ClearContents
   .[L5:AB5].Resize(R).ClearContents
   .[A5:H5].Resize(R).ClearContents
   If X.Count > 0 Then
      .[J4].Resize(X.Count, 1) = Application.Transpose(X.items)
   End If
   If Y.Count > 0 Then
      .[K4].Resize(Y.Count, 1) = Application.Transpose(Y.items)
   End If
   C = IIf(X.Count >= Y.Count, X.Count, Y.Count)
   If C <= 1 Then Exit Sub
   .[L4:AB4].Copy .[L5:AB5].Resize(C - 1)
   .[A4:H4].Copy .[A5:H5].Resize(C - 1)
End With
End Sub
Sub 清除()
With Sheets("最後效期")
   .[J4:K4].Resize(100).ClearContents
   .[L5:AB5].Resize(100).ClearContents
   .[A5:H5].Resize(100).ClearContents
End With
End Sub

Andy2483

回復 31# 准提部林
'謝謝前輩
'後學在此帖學習到
'1.沒有深入學習得不到精華
'2.習得批次宣告變數且批次數與迴圈搭配使用!初開始只以為少宣告幾個變數
'3.習得 If N(j) > NN Then 取最大數的方法
'4.習得 [J4:K4].Resize(NN) = Crr,以前只會 [J4].Resize(NN,2)
'5.周到的防錯需要再累積經驗!才能辦到
以下心得註解請在指教! 謝謝前輩

Sub 最後效期()
Dim Arr, Brr, Crr, R&, i&, j%, N&(1 To 2), NN&, BK As Workbook
'↑宣告變數
R = [飛比!HE65536].End(xlUp).Row
'↑令R是 HE欄儲存格有內容的最後一列數
Arr = Sheets("飛比").Range("F1:F" & R)
'↑令Arr是陣列 倒入飛比表 的F1到
'F欄的(HE欄儲存格有內容的最後一列數) 的值
Brr = Sheets("飛比").Range("HD1:HE" & R)
'↑令Brr是陣列 倒入飛比表 的HD1到
'HE欄的(HE欄儲存格有內容的最後一列數) 的值
ReDim Crr(1 To R, 1 To 2)
'↑宣告Crr陣列的大小 綜方向 1到 HE欄儲存格有內容的最後一列數
'橫方向 1 到 2
For i = 4 To R
'↑設外順迴圈 從4 到 R
   For j = 1 To 2
   '↑設內順迴圈 從 1 到 2
      If Val(Brr(i, j)) > 0 Then
      '↑如果 惠 統 這兩欄裡的值大於0
         N(j) = N(j) + 1
         '↑N是這兩欄符合If條件次數的變數!初始值是0
         Crr(N(j), j) = Arr(i, 1)
         '↑Crr陣列從第一列開始放入符合條件 的膠帶顏色
         If N(j) > NN Then
         '↑如果大於 NN
         '↑當N(j)=1時,NN的初始值是0 !條件成立
            NN = N(j)
            '↑條件成立!就讓NN =符合If條件次數
            '↑當N(j)=1時 條件成立! NN=1
            '↑後續如果 N(1) N(2)不相等!NN會裝入最大數
         End If
      End If
   Next j
Next i
If NN = 0 Then
'↑如果N()的最大數NN 是0!完全沒有符合條件的資料
   Exit Sub
   '↑結束程序
End If
With Sheets("最後效期")
'↑接下來關於 最後效期表的相關程序(前面有 空白+"."符號的")
    .[J4:K4].Resize(NN) = Crr
    '↑由 最後效期表 的[J4:K4](含)開始向下擴展 NN列的範圍貼入Crr的值
    '雖然 ReDim Crr(1 To R, 1 To 2)宣告的範圍比 最後結果範圍大!
    '但是精準計算!有效Resize擴展結果範圍,就不會影響其他儲存格
    If NN <= 1 Then Exit Sub
    '↑如果N()的最大數NN=1,就 結束程序
    .[L4:AB4].Copy .[L5:AB5].Resize(NN - 1)
    '↑將 最後效期表[L4:AB4]儲存格 複製到
    '最後效期表[L5:AB5](含)開始向下擴展 NN-1列
    .[A4:H4].Copy .[A5:H5].Resize(NN - 1)
    '↑將 最後效期表[A4:H4]儲存格 複製到
    '最後效期表[A5:H5](含)開始向下擴展 NN-1列
End With
End Sub

准提部林

回復 30# PJChen

Sub 最後效期()
Dim Arr, Brr, Crr, R&, i&, j%, N&(1 To 2), NN&, BK As Workbook
'Set BK = Workbooks("最新庫存.xlsx")
'BK.Sheets("最後效期").Activate
R = [飛比!HE65536].End(xlUp).Row
Arr = Sheets("飛比").Range("F1:F" & R)
Brr = Sheets("飛比").Range("HD1:HE" & R)
ReDim Crr(1 To R, 1 To 2)
For i = 4 To R
For j = 1 To 2
    If Val(Brr(i, j)) > 0 Then
       N(j) = N(j) + 1: Crr(N(j), j) = Arr(i, 1)
       If N(j) > NN Then NN = N(j)
    End If
Next j
Next i
If NN = 0 Then Exit Sub
With Sheets("最後效期")
    .[J4:K4].Resize(NN) = Crr
    If NN <= 1 Then Exit Sub
    .[L4:AB4].Copy .[L5:AB5].Resize(NN - 1)
    .[A4:H4].Copy .[A5:H5].Resize(NN - 1)
End With
End Sub

PJChen

回復 29# 准提部林

准大,
1) 如圖,如何使J欄&K欄資料可以連續,且都從第4列開始載入資料?
2) 請問For i = 4 To R
該如何理解紅字部份?為何是4?

下載 (7.88 KB)

2020-6-16 16:52

最新庫存A.rar (85.21 KB)

下載次數: 3

2020-6-16 16:52

准提部林

回復 28# PJChen


Sub 最後效期()
Dim Arr, Brr, Crr, R&, i&, N&, BK As Workbook
Set BK = Workbooks("最新庫存.xlsx")
BK.Sheets("最後效期").Activate
R = [飛比!HE65536].End(xlUp).Row
Arr = Sheets("飛比").Range("F1:F" & R)
Brr = Sheets("飛比").Range("HD1:HE" & R)
ReDim Crr(1 To R, 1 To 2)
For i = 4 To R
    If Val(Brr(i, 1)) + Val(Brr(i, 2)) = 0 Then GoTo 101
    N = N + 1
    If Brr(i, 1) > 0 Then Crr(N, 1) = Arr(i, 1)
    If Brr(i, 2) > 0 Then Crr(N, 2) = Arr(i, 1)
101: Next i
If N = 0 Then Exit Sub
With Sheets("最後效期")
    .[J4:K4].Resize(N) = Crr
    If N > 1 Then
      .[L4:AB4].Copy .[L5:AB5].Resize(N - 1)
      .[A4:H4].Copy .[A5:H5].Resize(N - 1)
    End If
End With
End Sub

PJChen

回復 27# 准提部林

最後效期,A4:H4,L4:AB4原來都有公式,作為動態表格使用,
程式只有做二個動作:
1) 將來源料號填入J:K欄,
2) 最後依據K欄的列數,將A4:H4,L4:AB4的公式下拉即可  
最後效期.rar (82.19 KB)

下載次數: 2

2020-6-16 12:42

下載 (22.64 KB)

2020-6-16 12:41

准提部林

回復 26# PJChen

你這程式碼根本拿不到任何資料!!!
應該是完全不了解原程式碼的意思, 這樣是無法套用的~~

光是這不成套的程式碼及簡單的說明, 無法了解詳細需求規則,
好像每次的提問, 我幾乎都抓不到要的是什麼???只能用猜,
這總不是辦法, 或許再研究一下提問方式, 讓別人都可了解清楚你的目的!!!

PJChen

回復 23# 准提部林

准大,
我修改了這個程式,想讓
HD欄>0,則填入,最後效期sheet的J欄
HE欄>0,則填入,最後效期sheet的K欄
目前只try了HE欄,但無法填入,可以幫我看看嗎?    最新庫存.rar (82.58 KB)

下載次數: 1

2020-6-16 00:14

1. Sub  最後效期()
   
2. Dim Arr, Brr, R&, 統&, N&, BK As Workbook
   
3. Set BK = Workbooks("最新庫存.xlsx")
   
4. BK.Sheets("最後效期").Activate
   
5. Arr = Range([飛比!A1], [飛比!HE65536].End(xlUp))
   
6. For R = 4 To UBound(Arr)
   
7.     統 = Val(Arr(R, UBound(Arr, 2)))
   
8.     If 統 = 0 Then GoTo 101
   
9.     N = N + 1
   
10.     Arr(N, 11) = Arr(R, 5) '料號
    
11. 101: Next R
    
12. If N = 0 Then Exit Sub
    
13. 
    
14. With [最後效期!A4:H4].Resize(N)
    
15.      .Rows(1).Copy .Cells
    
16. End With
    
17. With [最後效期!L4:AB4].Resize(N)
    
18.      .Rows(1).Copy .Cells
    
19. End With
    
20. End Sub

複製代碼

PJChen

回復 23# 准提部林

准大,
感謝你,我改好了