准提部林

回復 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

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

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