請教資料彙整問題

yuch8663

我有四張表單，筆數均超過10000筆以上，其中以sheet1的sdata、stockid兩欄為基準要將四張表單的相關資料匯整到sheet5裡，其中sheet3裡會有重複的日期不要複製過去，其結果如附檔內所示，因為用函數來跑，速度非常慢，想請各位版主能幫忙VBA程式要如何寫?謝謝。 Book1.rar (61.44 KB)

下載次數: 24

2010-6-6 22:18

Hsieh

回復 1# yuch8663

1. Sub Ex()
   
2. Dim Sh As Worksheet, Ar(), A As Range, B As Range, C As Range, s&, i%
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. For Each Sh In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
   
6. With Sh
   
7. Set C = IIf(i = 0 Or i = 2, .[A1], .[C1])
   
8.    For Each A In .Range(C, .[IV1].End(xlToLeft))
   
9.        ReDim Preserve Ar(s)
   
10.        Ar(s) = A.Value
    
11.        s = s + 1
    
12.        For Each B In .Range(A.Offset(1, 0), .Cells(65536, A.Column).End(xlUp))
    
13.           If i = 0 Then
    
14.              d1(.Cells(B.Row, 1) & .Cells(B.Row, 2)) = Array(.Cells(B.Row, 1), .Cells(B.Row, 2))
    
15.              d(.Cells(B.Row, 1) & .Cells(B.Row, 2) & A) = B.Value
    
16.              ElseIf d1.exists(.Cells(B.Row, 1) & .Cells(B.Row, 2)) = True Then
    
17.              d(.Cells(B.Row, 1) & .Cells(B.Row, 2) & A) = B.Value
    
18.           End If
    
19.        Next
    
20.     Next
    
21.     i = i + 1
    
22. End With
    
23. Next
    
24. With Sheet5
    
25. .Cells = ""
    
26. .[A1].Resize(, s) = Ar
    
27. r = d1.Count
    
28. .[A2].Resize(d1.Count, 2) = Application.Transpose(Application.Transpose(d1.items))
    
29. For Each C In .Range(.[C1], .[IV1].End(xlToLeft))
    
30.    For Each A In C.Offset(1, 0).Resize(d1.Count, 1)
    
31.       A = d(.Cells(A.Row, 1) & .Cells(A.Row, 2) & C)
    
32.    Next
    
33. Next
    
34. End With
    
35. End Sub

複製代碼

yuch8663

剛回到家中打開電腦看到hsieh版主的回覆，萬分感激，待我先來測試，如有問題再來請教，謝謝!

yuch8663

回復 3# yuch8663


    請問hsieh版主，昨晚回家測試發先兩個問題，請問要如何修改?謝謝。

下載 (240.37 KB)

2010-6-8 09:24

下載 (224.27 KB)

2010-6-8 09:25

Book1.rar (28.13 KB)

下載次數: 8

2010-6-8 09:24

GBKEE

回復 4# yuch8663

1. Sub Ex()
   
2. Dim D As Object, D1 As Object, Sh As Worksheet, Ar(), A As Range, B As Range
   
3. Set D = CreateObject("Scripting.Dictionary")
   
4. Set D1 = CreateObject("Scripting.Dictionary")
   
5. ReDim Preserve Ar(2)
   
6. Ar(0) = Sheets("Sheet1").[A1]
   
7. Ar(1) = Sheets("Sheet1").[B1]
   
8. For Each Sh In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
   
9. With Sh
   
10. For Each A In .Range(.[C1], .[IV1].End(xlToLeft))
    
11. If Not IsNumeric(Application.Match(A, Ar, 0)) Then
    
12. Ar(UBound(Ar)) = A.Value
    
13. ReDim Preserve Ar(UBound(Ar) + 1)
    
14. End If
    
15. For Each B In .Range(A.Offset(1, 0), .Cells(65536, A.Column).End(xlUp))
    
16. D1(.Cells(B.Row, 1) & .Cells(B.Row, 2)) = Array(.Cells(B.Row, 1), .Cells(B.Row, 2))
    
17. D(.Cells(B.Row, 1) & .Cells(B.Row, 2) & A) = D(.Cells(B.Row, 1) & .Cells(B.Row, 2) & A) + B.Value
    
18. Next
    
19. Next
    
20. End With
    
21. Next
    
22. With Sheet5
    
23. .Cells = ""
    
24. .[A1].Resize(, UBound(Ar)) = Ar
    
25. .[A2].Resize(D1.Count, 2) = Application.Transpose(Application.Transpose(D1.ITEMS))
    
26. For Each C In .Range(.[C1], .[IV1].End(xlToLeft))
    
27. For Each A In C.Offset(1, 0).Resize(D1.Count, 1)
    
28. A = D(.Cells(A.Row, 1) & .Cells(A.Row, 2) & C)
    
29. Next
    
30. Next
    
31. End With
    
32. End Sub

複製代碼

Hsieh

回復 4# yuch8663


1.日期欄位重複只需改這行
Set C = IIf(i = 0, .[A1], .[C1])
2.因為SHEET1跟SHEET4的eq欄名重複只需將其中一欄更名即可

yuch8663

剛回家開電腦看到hsieh版主的解釋，非常感謝，因為我對陣列的迴圈一直無法理解，因此想要自行修改卻不知如何下手，待會就再來測試，同時也感謝GBKEE版主提供的程式，也會同時做測試，再次感謝。

Andy2483

回復 2# Hsieh


    謝謝前輩
太厲害了!後學覺得很難!
後學在此帖學到很多知識!
將心得在此註解一下
如有冒犯請見諒!也懇請前輩指正並指導!

Sub Ex_Hsieh()
Dim Sh As Worksheet, Ar(), A As Range, B As Range, C As Range, s&, i%
'↑宣告變數

Set d = CreateObject("Scripting.Dictionary")
'↑令d 是字典

Set d1 = CreateObject("Scripting.Dictionary")
'↑令d1 是字典

For Each Sh In Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4"))
'↑設外迴圈,令 Sh 是4個工作表之一,順著跑

   With Sh
   '↑以下關於Sh 工作表的程序
   
      Set C = IIf(i = 0 Or i = 2, .[A1], .[C1])
      '↑令C儲存格物件變數:如果i這變數是0或2, C儲存格=Sh的[A1]儲存格
      ',如果i這變數不是0或2, C儲存格=Sh的[C1]儲存格
      
      For Each A In .Range(C, .[IV1].End(xlToLeft))
      '↑設中迴圈,令A 儲存格物件變數是??
      '當i=0(初始值):C是[A1]儲存格,.[IV1].End(xlToLeft)是第一列最左邊的儲存格
      '所以A 是 Sheet1 的[A1:H1]的儲存格之一
      
         ReDim Preserve Ar(s)
         '↑調整Ar陣列大小，保留陣列內部資料
         '一開始Ar 是一維陣列,s初始值是0,Ar(0) 是沒有資料
         
         Ar(s) = A.Value
         '↑令Ar是標題列的值
         
         s = s + 1
         '↑令累加1,讓Ar陣列往右 排入標題列的值
         
         DDD = .Range(A.Offset(1, 0), .Cells(65536, A.Column).End(xlUp)).Address
         For Each B In .Range(A.Offset(1, 0), .Cells(65536, A.Column).End(xlUp))
         '↑設內迴圈,令 B儲存格物件變數:A標題列格偏下1格到 當欄的最後一格
         '當i=0(初始值);Sh=Sheet1;A=[A1];B=[A2:A105]
         '所以 B Sheet1 的[A2:A105]的儲存格之一
         
            If i = 0 Then
            '↑如果i是初始值0,也就是工作表是 Sheet1 時
            '目的是要收集標題欄兩欄的值與 日期&股代號&標題列格 拚字串的key,Item是 CreditMoney欄值
            
               d1(.Cells(B.Row, 1) & .Cells(B.Row, 2)) = Array(.Cells(B.Row, 1), .Cells(B.Row, 2))
               '↑條件成立時 d1字典裝入 日期&股代號 拚字串的 key ,Item是朗元素的一維陣列 日期;股代號
               
               d(.Cells(B.Row, 1) & .Cells(B.Row, 2) & A) = B.Value
               '↑條件成立時 d字典裝入 日期&股代號&標題列格 拚字串的key,Item是 CreditMoney欄值
               
               ElseIf d1.exists(.Cells(B.Row, 1) & .Cells(B.Row, 2)) = True Then
               '↑如果i不是是初始值0:工作表不是 Sheet1 時
               ',而且 d1字典裡有 日期&股代號 拚字串的 key時
                  
                  d(.Cells(B.Row, 1) & .Cells(B.Row, 2) & A) = B.Value
                  '↑條件成立時 d字典裝入 日期&股代號&標題列格 拚字串的key,Item是 CreditMoney欄值
                  
            End If
         Next
      Next
      i = i + 1
   End With
Next
With Sheet5
'↑以下關於 第5個工作表的程序

   .Cells = ""
   '↑令所有儲存個都是空字元
   
   .[A1].Resize(, s) = Ar
   '↑把收集到的Ar標題一維陣列從[A1]開始的儲存格放進值
   
   r = d1.Count
   '↑令r 是d1字典裡元素數量104
   
   .[A2].Resize(d1.Count, 2) = Application.Transpose(Application.Transpose(d1.items))
   '↑把收集到d1字典的item(兩欄標題) 從[A2]開始的儲存格放進值
   
   For Each C In .Range(.[C1], .[IV1].End(xlToLeft))
   '↑設外迴圈令 C儲存格物件變數是 Sheet5 的[C1:AK1]的儲存格之一
   '也就是結果表的標提列儲存格
      
      For Each A In C.Offset(1, 0).Resize(d1.Count, 1)
      '↑設內迴圈令 A儲存格物件變數是 C標題列儲存格偏下一格開始,
      '往下匡列 (d1字典裡元素數量) 的儲存格 104格 的儲存格之一
      
         A = d(.Cells(A.Row, 1) & .Cells(A.Row, 2) & C)
         '↑用兩標題欄兩格值與標題列格拚的字串當key,
         '調出d字典裡的Item 值放到儲存格理
         
      Next
   Next
End With
End Sub

Andy2483

回復 2# Hsieh

謝謝前輩分享 把字典中的item一維陣列 轉至貼入工作表
D1(.Cells(B.Row, 1) & .Cells(B.Row, 2)) = Array(.Cells(B.Row, 1), .Cells(B.Row, 2))
~~~
.[A2].Resize(d1.Count, 2) = Application.Transpose(Application.Transpose(d1.items))
這很實用!
謝謝!

Andy2483

各位前輩好
後學今天運用了兩主題的重要技巧,拼湊出下列範例
http://forum.twbts.com/thread-22560-1-1.html
與本主題
http://forum.twbts.com/thread-513-1-1.html
Book1_20001017_7.zip (33.21 KB)

下載次數: 3

2022-10-17 13:43

懇請前輩們指正與指導! 謝謝
執行前:

下載 (150.78 KB)

2022-10-17 13:44

執行後:

下載 (465.3 KB)

2022-10-17 13:43