Board logo

標題: 修改程式 [打印本頁]
作者: fangsc    時間: 2012-10-8 23:35     標題: 修改程式

因檔案越來越大, 目的資料己到了115000筆, 而每個月的來源資料至少都有9000多筆, 用以下的程式來run, 每次都要跑2~3小時.
不知高手們是否可以教導修改程式,可以讓資料的輸入速度可以快一些 ?


Public put_column, row_clear, row_index, put_row, row_search As Long
Sub 抓資料()
put_column = Sheets("作業區").Range("b1").Value
Sheets("Summary").Activate
ans0 = MsgBox("確定是Load至【" & put_column & "】欄嗎？", vbYesNo, "請確認")
If ans0 <> 6 Then

    Sheets("作業區").Activate
    Range("b1").Select
    ans2 = MsgBox("請重新輸入正確的欄位！")
    End
End If
ans = MsgBox("要清空 【" & put_column & "】欄的資料嗎？" & Chr(13) & Chr(13) & "【是】→ 清空，再放入數據" & Chr(13) & Chr(13) & "【否】→ 不清空，數據繼續累加", vbYesNo, "請確認")
If ans = 6 Then
    row_clear = 3
    While Cells(row_clear, 1).Value <> ""
        row_clear = row_clear + 1
    Wend
    Range(put_column & Format(3) & ":" & put_column & Format(row_clear)).ClearContents
    load_data
Else
    load_data
End If
End Sub
Sub load_data()
row_index = 2
'從data的第二列開始尋找,一直找至Total為止
While Left(Sheets("data").Cells(row_index, 9).Value, 5) <> "Total"
    Prod = Sheets("data").Cells(row_index, 3).Value
    If Prod = "Electro-Dip" Or Prod = "Electro" Then
        '將四個欄位連結起來
        data_four_column = Sheets("data").Cells(row_index, 2).Value & Sheets("data").Cells(row_index, 3).Value & Sheets("data").Cells(row_index, 4).Value & Sheets("data").Cells(row_index, 9).Value
        '如果Summary的a3儲存格是空白
        If Sheets("Summary").Cells(3, 1).Value = "" Then
        '就直接將找到的第一筆資料放進第三列
            Sheets("Summary").Cells(3, 1).Value = Sheets("data").Cells(row_index, 2).Value
            Sheets("Summary").Cells(3, 2).Value = Sheets("data").Cells(row_index, 3).Value
            Sheets("Summary").Cells(3, 3).Value = Sheets("data").Cells(row_index, 4).Value
            Sheets("Summary").Cells(3, 4).Value = Sheets("data").Cells(row_index, 9).Value
            Sheets("Summary").Range(put_column & Format(3)).Value = Sheets("data").Cells(row_index, 10).Value
        '否則
        Else
            '從第三列開始找起
            row_search = 3
            got_it = False
            '一直找到空白為止
            While Sheets("Summary").Cells(row_search, 1).Value <> ""
                '將Summary的四個欄位連結起來
                four_column = Sheets("Summary").Cells(row_search, 1).Value & Sheets("Summary").Cells(row_search, 2).Value & Sheets("Summary").Cells(row_search, 3).Value & Sheets("Summary").Cells(row_search, 4).Value
                '如果在data找到的資料跟在Summary找到的相同,就把數量相加
                If data_four_column = four_column Then
                    got_it = True
                    Sheets("Summary").Range(put_column & Format(row_search)).Value = Sheets("Summary").Range(put_column & Format(row_search)).Value + Sheets("data").Cells(row_index, 10).Value
                End If
                    row_search = row_search + 1
            Wend
            '如果沒有找到相同的
            If got_it = False Then
                '就在最後一列新增一筆
                Sheets("Summary").Cells(row_search, 1).Value = Sheets("data").Cells(row_index, 2).Value
                Sheets("Summary").Cells(row_search, 2).Value = Sheets("data").Cells(row_index, 3).Value
                Sheets("Summary").Cells(row_search, 3).Value = Sheets("data").Cells(row_index, 4).Value
                Sheets("Summary").Cells(row_search, 4).Value = Sheets("data").Cells(row_index, 9).Value
                Sheets("Summary").Range(put_column & Format(row_search)).Value = Sheets("data").Cells(row_index, 10).Value
                row_search = row_search + 1
            End If
        End If
    End If
    row_index = row_index + 1
Wend
ans = MsgBox("已完成!")
End Sub
作者: GBKEE    時間: 2012-10-9 07:25

回復 1# fangsc
修正程式於開端就給值
  1. Sub load_data()
  2. row_index = 2       '從data的第二列開始尋找,一直找至Total為止
  3. row_search = 3      '從第三列開始找起   
  4. While Left(Sheets("data").Cells(row_index, 9).Value, 5) <> "Total"
  5. '
  6. '
複製代碼
  1. '否則
  2.         Else
  3.             '從第三列開始找起
  4.             row_search = 3                                 '***  每一次都從第三列找起  是這裡浪費時間 ****
  5.             got_it = False
  6.             '一直找到空白為止
  7.             While Sheets("Summary").Cells(row_search, 1).Value <> ""
  8.                 '將Summary的四個欄位連結起來
複製代碼
作者: fangsc    時間: 2012-10-10 00:57

回復 2# GBKEE

感謝版主的指導, 但這樣改好像只是將來源資料從目的工作表的最後一列開始load資料
並沒有去比對4個key值如果相同的話,就放進指定的欄位, 如果找不到4個key值,就到目前資料的最後一列新增一筆.
           將Summary的四個欄位連結起來
           如果在data找到的資料跟在Summary找到的相同,就把數量相加
           如果沒有找到相同的
            就在最後一列新增一筆
作者: GBKEE    時間: 2012-10-10 09:15

回復 3# fangsc
附檔中沒 Sheets("data") 這工作表
作者: fangsc    時間: 2012-10-10 14:35

回復 4# GBKEE

不好意思,請見附檔. 謝謝.
作者: GBKEE    時間: 2012-10-10 17:44

本帖最後由 GBKEE 於 2012-10-10 19:22 編輯

回復 5# fangsc
試試看
  1. Sub load_data()
  2.     Dim row_index As Integer,row_search As Integer, D As Object, K As Variant, T As Date
  3.     T = Time
  4.     Set d = CreateObject("SCRIPTING.DICTIONARY")         '字典物件
  5.     With Sheets("data")
  6.         row_index = 2
  7.         '從data的第二列開始尋找,一直找至Total為止
  8.         While Left(.Cells(row_index, 9).Value, 5) <> "Total"
  9.             'Prod = Sheets("data").Cells(row_index, 3).Value
  10.             If .Cells(row_index, 3) = "Electro-Dip" Or .Cells(row_index, 3) = "Electro" Then
  11.                 '將四個欄位連結起來
  12.                 data_four_column = .Cells(row_index, 2) & ",," & .Cells(row_index, 3) & ",," & .Cells(row_index, 4) & ",," & .Cells(row_index, 9)
  13.                 If d.EXISTS(data_four_column) Then   '字典物件 關鍵字 (key) 存在
  14.                     d(data_four_column) = d(data_four_column) + .Cells(row_index, 10).Value
  15.                 Else
  16.                     d(data_four_column) = .Cells(row_index, 10).Value
  17.                     ''字典物件 關鍵字(key)加入 並指定 項目 (item)
  18.                 End If
  19.             End If
  20.             row_index = row_index + 1
  21.         Wend
  22.     End With
  23.      With Sheets("Summary")
  24.         row_search = 3
  25.         If .Cells(3, 1).Value = "" Then  '如果Summary的a3儲存格是空白
  26.            For Each K In d.KEYS          '取出字典物件 關鍵字
  27.             .Cells(row_search, 1).Resize(, 4) = Split(K, ",,")
  28.             .Range(put_column & row_search) = d(K)  '取出字典物件的item(項目)
  29.             row_search = row_search + 1
  30.            Next
  31.         Else
  32.             While .Cells(row_search, 1) <> ""
  33.                 K = Join(Application.Transpose(Application.Transpose(.Cells(row_search, 1).Resize(, 4).Value)), ",,")
  34.                 If d.EXISTS(K) Then        '字典物件 關鍵字 (key) 存在
  35.                     .Range(put_column & row_search) = .Range(put_column & row_search) + d(K)
  36.                     d.Remove K             '字典物件 移除 關鍵字 (key)
  37.                 End If
  38.                 row_search = row_search + 1
  39.             Wend
  40.             If d.Count > 1 Then     '沒比對到的資料
  41.                For Each K In d.KEYS
  42.                     .Cells(row_search, 1).Resize(, 4) = Split(K, ",,")
  43.                     .Range(put_column & row_search) = d(K)
  44.                     row_search = row_search + 1
  45.                 Next
  46.             End If
  47.         End If
  48.     End With
  49.     MsgBox (Format(Time - T, "nn分SS秒") & " 已完成!")
  50. End Sub
複製代碼
作者: fangsc    時間: 2012-10-10 22:56

回復 6# GBKEE

感謝版主,原本要run 2~3小時,現在只要3秒.實在厲害. 真的好比是兎子跟烏龜的速度相比.令人望塵莫及.
不過要看懂你的程式, 我還要認真的研讀.
因為目地工作表的列資料太大,發生"溢位"的錯誤訊息, 所以我將 row_search As Integer 改為 Long.
感謝!!
作者: Hsieh    時間: 2012-10-11 01:11

本帖最後由 Hsieh 於 2012-10-11 09:31 編輯

回復 5# fangsc
  1. Sub ex()
  2. Dim d As Object, SumColumn$, n$, i%, A As Range, Mystr$, ky As Variant, Ay(), ar()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. 10
  5. SumColumn = InputBox("輸入欄位", , "AN")
  6. If SumColumn = "" Then GoTo 10
  7. [B1] = SumColumn
  8. With Sheets("Summary")
  9.   For Each A In .Range(.[A3], .[A2].End(xlDown))
  10.      Mystr = Join(Application.Transpose(Application.Transpose(A.Resize(, 4))), ",")
  11.      d(Mystr) = Array(A.Value, A.Offset(, 1).Value, A.Offset(, 2).Value, A.Offset(, 3).Value, .Cells(A.Row, SumColumn).Value)
  12.   Next
  13.   With Sheets("data")
  14.     For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
  15.     If InStr(A.Offset(, 2), "Electro") > 0 Then
  16.        Mystr = A.Offset(, 1) & "," & A.Offset(, 2) & "," & A.Offset(, 3) & "," & A.Offset(, 8)
  17.        If IsEmpty(d(Mystr)) Then
  18.        d(Mystr) = Array(A.Offset(, 1).Value, A.Offset(, 2).Value, A.Offset(, 3).Value, A.Offset(, 8).Value, A.Offset(, 9).Value)
  19.        Else
  20.        ar = d(Mystr)
  21.        ar(UBound(ar)) = ar(UBound(ar)) + A.Offset(, 9)
  22.        d(Mystr) = ar
  23.        End If
  24.     End If
  25.     Next
  26.   End With
  27.   Ay = Application.Transpose(Application.Transpose(d.items))
  28.   .[A3].Resize(d.Count, 4) = Ay
  29.   .Cells(3, SumColumn).Resize(d.Count, 1) = Application.Index(Ay, , 5)
  30. End With
  31. End Sub
複製代碼
作者: fangsc    時間: 2012-10-11 21:27

回復 8# Hsieh

感謝版主,真的超級厲害的快,想說按下執行鍵,可以拿起杯子喝口水,哪知杯子還沒到嘴邊,程式就跑完了.
程式看起來還是難懂, 要認真的爬文了.  謝謝哦!!



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)