請問資料比對且運算到工作表三

enhrulee

各位前輩好
爬文找了很多文章雖然有找到類似的問題
但是檔案也不能下載只好重複問一下類似的問題
工作表一
今天的交易品項與數量
工作表二是
今天商品的報價
工作表三是
營業額的記錄區

商品有很多種但是每天交易的商品種類不固定數量也不固定
例如商品總共有99種
第一天交易的商品是1,3,5,8,16,72,44,56
第二天交易的商品是9,61,77,51,34,26,89,54,59,68,
每天商品的報價也不同

希望在工作表三記錄下
所有商品每日的營業額
工作表欄位分別為
A1:產品名稱
B1:累計20日營業額
C1~V1:日期
每次新增一日的營業額都在C欄,而原紀錄在C欄~V欄則往右移
原本V欄最早的記錄則刪除
也就是說工作表三永遠只保留二十日的營業額記錄
交易紀錄.rar (24.91 KB)

下載次數: 17

2011-7-23 11:19

GBKEE

回復 1# enhrulee
試試看

1. Sub Ex()
   
2.     Dim D As Object, DX As Object, Rng As Range
   
3.     Set D = CreateObject("SCRIPTING.DICTIONARY")   '今日報價 物件
   
4.     Set DX = CreateObject("SCRIPTING.DICTIONARY")  '今日報價*今日單量 物件
   
5.     Set Rng = Sheets("今日報價").Range("A2")
   
6.     Do While Rng <> ""                             '取得 產品今日報價物件的 迴圈
   
7.         D(Rng.Value) = Rng.Offset(, 1).Value
   
8.         Set Rng = Rng.Offset(1)                    '設定為往下一列
   
9.     Loop
   
10.     Set Rng = Sheets("今天交易").Range("A2")
    
11.     Do While Rng <> ""                          '取得 今日產品報價  * 今天單量 =金額 的迴圈
    
12.         If DX.EXISTS(Rng.Value) Then            '今日產品單量已出現
    
13.             DX(Rng.Value) = DX(Rng.Value) + D(Rng.Value) * Rng.Offset(, 1).Value
    
14.         Else
    
15.             DX(Rng.Value) = D(Rng.Value) * Rng.Offset(, 1).Value
    
16.         End If
    
17.        'DX.EXSITS(Rng.Value)        今天交易的產品名稱存在
    
18.        'D(Rng.Value)                產品 今日報價
    
19.        'Rng.Offset(, 1).Value       產品 今日單量
    
20.        'DX(Rng.Value)               今天單量*今日報價
    
21.         Set Rng = Rng.Offset(1)
    
22.     Loop
    
23.     With Sheets("交易紀錄")
    
24.         If .Range("C1") <> Date Then    '不是當日
    
25.             .Columns("C:C").Insert
    
26.             .Columns("V:V") = ""
    
27.             .Range("C1") = Date
    
28.         End If
    
29.         Set Rng = .Range("A2")
    
30.         Do While Rng <> ""      '取得 今天有交易紀錄 產品  的迴圈
    
31.             If DX.EXISTS(Rng.Value) Then Rng.Offset(, 2) = DX(Rng.Value)
    
32.             '產品今日有交易  C欄輸入總金額
    
33.             Rng.Offset(, 1) = "=SUM(" & Rng.Offset(, 2).Resize(1, 20).Address & ")" '
    
34.             'B欄輸入公式
    
35.             Set Rng = Rng.Offset(1)
    
36.         Loop
    
37.     End With
    
38. End Sub

複製代碼

enhrulee

回復  enhrulee
試試看
GBKEE 發表於 2011-7-23 14:42

    感謝版主的熱心幫忙
我有稍微修改了一小部分
If .Range("C1") <> Date Then    '不是當日
            .Columns("C:C").Insert
            .Columns("W:W") = ""
            .Range("C1") = Date
        End If

應該是執行順序的原因
原本版主寫的程式會刪除掉原第二天(U欄)的資料
小小的修正就OK了~
超級感謝的還有中文註解
真的很貼心
:$

GBKEE

回復 3# enhrulee
程式會刪除掉原第二天(U欄)的資料
.Columns("V:V") = ""     
是刪除掉V欄,你跟我一樣粗心.

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

今日交易表 & 今日報價表:

下載 (35.38 KB)

2023-5-24 10:57

  

下載 (34.07 KB)

2023-5-24 10:58

結果表執行前:

下載 (343.78 KB)

2023-5-24 11:01

執行結果:

下載 (337.1 KB)

2023-5-24 11:01

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr, Y, i&
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是 字典
Brr = Range([今日報價!B2], [今日報價!A65536].End(3))
'↑令Brr變數是 二維陣列,以今日報價表 儲存格值帶入陣列裡
For i = 1 To UBound(Brr): Y(Brr(i, 1) & "/報") = Brr(i, 2): Next
'↑設順迴圈,令產品名稱 連接 "/報"當key,item是B欄的報價
Brr = Range([今天交易!B2], [今天交易!A65536].End(3))
'↑令Brr變數是 二維陣列,以今天交易表儲存格值帶入陣列裡
For i = 1 To UBound(Brr): Y(Brr(i, 1) & "/易") = Y(Brr(i, 1) & "/易") + Brr(i, 2): Next
'↑設順迴圈,令產品名稱 連接 "/易"當key,item是B欄的單量做累加
Arr = Range([交易紀錄!A1], [交易紀錄!A65536].End(3))
'↑令Arr變數是 二維陣列,以交易紀錄表 A欄儲存格值帶入陣列裡
If [交易紀錄!C1] = Date Then
'↑如果[交易紀錄!C1]儲存格值是 今天日期,代表今日已經執行過
   Crr = Range([交易紀錄!V1], [交易紀錄!C65536].End(3))
   '↑令Crr變數是 二維陣列,以交易紀錄表C~V欄儲存格值帶入陣列
   Else '否則
      Crr = Range([交易紀錄!V1], [交易紀錄!B65536].End(3))
      '↑令Crr變數是 二維陣列,以交易紀錄表B~V欄儲存格值帶入陣列
End If
For i = 2 To UBound(Crr)
'↑設順迴圈
   Crr(i, 1) = Y(Arr(i, 1) & "/報") * Y(Arr(i, 1) & "/易")
   '↑令Crr陣列的第1欄帶入查Y字典計算出來的每個產品交易金額
Next
Crr(1, 1) = Date
'↑令Crr陣列1索引號列1索引號欄陣列值是 今天日期
[交易紀錄!C1].Resize(UBound(Crr), 20) = Crr
'↑令Crr陣列值從[交易紀錄!C1]開始寫入儲存格裡
Set Y = Nothing: Erase Arr,Brr, Crr
'↑令釋放變數
End Sub