123
返回列表 上一主題 發帖

[發問] 請問如果有一個股票資料庫，如何使用vba…

gkld

帖子
44 
主題
7 
精華
0 
積分
51 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
註冊時間
2012-11-18 
最後登錄
2022-8-6 

論壇贊助勳章
1# 跳轉到 » 正序看帖
打印
tT
發表於 2012-12-26 22:04 | 只看該作者

[發問] 請問如果有一個股票資料庫，如何使用vba…

請問 如果我有一個股票的資料庫，裡面檔名是A11220070102ALL_1.csv、A11220070103ALL_1.csv、A11220070104ALL_1.csv ……等，代表不同日期2007/01/02、2007/01/03、2007/01/04的股票資料，
該資料庫裡有非常多筆.csv檔，每個檔案打開
如圖
現在我想要從這個資料庫內整裡出不同日期的歷史股價，格式如圖
請問如何用vba寫出來了呢？救救我吧~謝謝大家~
收藏 分享

gkld

帖子
44 
主題
7 
精華
0 
積分
51 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
註冊時間
2012-11-18 
最後登錄
2022-8-6 

論壇贊助勳章
23#
發表於 2013-3-11 21:34 | 只看該作者
回復 22# GBKEE
ok~:D
我已修正完成~
感謝板大細心指導!!

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
22#
發表於 2013-3-11 08:22 | 只看該作者
本帖最後由 GBKEE 於 2013-3-11 08:25 編輯

回復 21# gkld
說明18#程式碼編寫的邏輯
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook
  4.     Dim Rng As Range, Ex_Row As Integer, i As Integer
  5.     Dim Ar() As String, Wb As Workbook
  6.     'Set Wb = Workbooks.Open("D:\股票資料庫.xls")    '開啟股票資料庫的活頁簿
  7.     Ex_Path = "C:\Documents and Settings\gkld\桌面\my kp\資料庫\上市\"   
  8.     Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  9.     If Ex_File = "" Then
  10.         MsgBox "沒有 A112*ALL_1.csv"
  11.         Exit Sub
  12.     End If
  13.     Application.ScreenUpdating = False
  14.     Ar = Array("台泥", "亞泥", "嘉泥", "幸福", "信大", "東泥")
  15.     Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  16.     Do While Ex_File <> ""                    ' 尋找 *.csv  的迴圈
  17.          '.............簡略
  18.         For i = 1 To 7                        '工作表的迴圈
  19.             With Sheets(Ar(i - 1))                                      '指定定陣列中的工作表名稱
  20.                 '.............簡略
  21.                 If Not .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Exit For
  22.                 'If Not .Columns(1).Find 迴圈比對在工作表中比對日期的 If 條件式

  24.                  'Exit For:離開For i = 1 To 7 這回圈:不再重複舊有的資料
  25.                 Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 不存日期 的.csv.....
  26.                 '.............簡略
  27.             End With
  28.             Ex_Wb.Close False                                    '關閉 A11220070102ALL_1.csv.....
  29.         Next
  30.         '**************************************
  31.         Ex_File = Dir                                            '下一個"A112*ALL_1.csv"
  32.         'PS 18# 的程式碼有錯誤:  18# 43行程式碼  Ex_File = Dir  須移到  Loop 的前一行 繼續找下一個"A112*ALL_1.csv"
  33.     Loop
  34.         '**************************************
  35.     Application.ScreenUpdating = True
  36.     MsgBox "OK"
  37. End Sub
複製代碼

TOP

gkld

帖子
44 
主題
7 
精華
0 
積分
51 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
註冊時間
2012-11-18 
最後登錄
2022-8-6 

論壇贊助勳章
21#
發表於 2013-3-10 21:09 | 只看該作者
回復 20# gkld
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook
  4.     Dim Rng As Range, Ex_Row As Integer, i As Integer
  5.     Ex_Path = "C:\Documents and Settings\gkld\桌面\my kp\資料庫\old 上市\"
  6.     Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  7.     If Ex_File = "" Then
  8.         MsgBox "沒有 A112*ALL_1.csv"
  9.         Exit Sub
  10.     End If
  11.     Application.ScreenUpdating = False
  12.   
  13.     For i = 2 To 8
  14.    
  15.         With Sheets(i)
  16.         
  17.             .Range("a1") = "日期"           '製作表頭
  18.             .Range("b1") = "收盤"
  19.             .Range("c1") = "漲跌"
  20.             .Range("d1") = "漲跌率"
  21.             .Range("e1") = "開盤"
  22.             .Range("f1") = "最高"
  23.             .Range("g1") = "最低"
  24.             .Range("h1") = "成交量(單位)"
  25.             .Range("i1") = "成交量"
  26.             Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  27.             Do While Ex_File <> ""
  28.                 Ex_Date = Replace(Ex_File, "A112", "")                     '消除檔名中"A112"
  29.                 Ex_Date = Replace(Ex_Date, "ALL_1.csv", "")                '消除檔名中"ALL_1.csv"
  30.                 Ex_Date = DateSerial(Mid(Ex_Date, 1, 4), Mid(Ex_Date, 5, 2), Mid(Ex_Date, 7, 2)) '帶入日期
  31.                 If Not .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Exit For
  32.                 '***  不再重複舊有資料  ****'CDate(Ex_Date)日期 -> 工作表A欄中 找到日期(有):離開回圈
  33.                 'CDate函數   Date任何可使用的日期運算式。
  34.                     Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 A11220070102ALL_1.csv.....
  35.                 '************************************************
  36.                 Ex_Row = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row '取得資料輸入的列號
  37.                 Set Rng = Ex_Wb.Sheets(1).Range("a:a").Find(.Name, LookAt:=xlWhole)
  38.             
  39.                 If Not Rng Is Nothing Then
  40.                     .Cells(Ex_Row, "A") = Ex_Date '日期輸入  如移到這裡 '** 只記錄有資料的日期
  41.                     .Cells(Ex_Row, "B") = Rng.Offset(, 8)
  42.                     .Cells(Ex_Row, "e") = Rng.Offset(, 5)
  43.                     .Cells(Ex_Row, "f") = Rng.Offset(, 6)
  44.                     .Cells(Ex_Row, "g") = Rng.Offset(, 7)
  45.                     .Cells(Ex_Row, "i") = Rng.Offset(, 2)
  46.                 End If
  47.                 '************************************************
  48.                 Ex_Wb.Close False                                       '關閉 A11220070102ALL_1.csv.....
  49.                ' End If                                                            '*****一周內的日期
  50.                 Ex_File = Dir                                               '下一個"A112*ALL_1.csv"
  51.             Loop
  52.         End With
  53.     Next
  54.     Application.ScreenUpdating = True
  55.     MsgBox "OK"
  56. End Sub
複製代碼
放的位置如上，我執行的時候，就直接跳出我的i=2 to 8 這個回圈了

該如何解決？

TOP

gkld

帖子
44 
主題
7 
精華
0 
積分
51 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
註冊時間
2012-11-18 
最後登錄
2022-8-6 

論壇贊助勳章
20#
發表於 2013-3-10 20:37 | 只看該作者
回復 18# GBKEE
板大…如果程式碼如下
  1. Sub Ex()
  2.     Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook
  3.     Dim Rng As Range, Ex_Row As Integer, i As Integer ', Ar() As String, Ex_Name As String
  4.     Ex_Path = "C:\Documents and Settings\gkld\桌面\my kp\資料庫\old 上市\"
  5.     Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  6.     If Ex_File = "" Then
  7.         MsgBox "沒有 A112*ALL_1.csv"
  8.         Exit Sub
  9.     End If
  10.     Application.ScreenUpdating = False
  11.     'Ar = Array("台泥", "亞泥", "嘉泥", "幸福", "信大", "東泥")
  12.     For i = 2 To 8
  13.        '** Name 是VBA所用的關鍵字串,避免使用為變數名稱.
  14.        ' If i = 1 Then Ex_Name = "台泥"
  15.        ' If i = 2 Then Ex_Name = "亞泥"
  16.        ' If i = 3 Then Ex_Name = "嘉泥"
  17.        ' If i = 4 Then Ex_Name = "環泥"
  18.        ' If i = 5 Then Ex_Name = "幸福"
  19.        ' If i = 6 Then Ex_Name = "信大"
  20.        ' If i = 7 Then Ex_Name = "東泥"
  21.       
  22.         With Sheets(i)                                                '依工作表索引值指定工作表
  23.         '****工作表名稱 在活頁簿視窗排序如是依IF i=1如此順序***
  24.         '***那就不需這些IF i=1 ...........
  25.       
  26.         'With Sheets(Ex_Name)                                          '依Ex_Name 指定工作表
  27.         '****如在活頁簿視窗工作表名稱排序不是如此順序***
  28.         '***那就需要這些IF i=1 ...........
  29.       
  30.         'With Sheets(Ar(i - 1))                                      '指定定陣列中的工作表名稱
  31.             .Range("m1:ag65536").Clear '消除每一行資料
  32.             .Range("a1") = "日期"           '製作表頭
  33.             .Range("b1") = "收盤"
  34.             .Range("c1") = "漲跌"
  35.             .Range("d1") = "漲跌率"
  36.             .Range("e1") = "開盤"
  37.             .Range("f1") = "最高"
  38.             .Range("g1") = "最低"
  39.             .Range("h1") = "成交量(單位)"
  40.             .Range("i1") = "成交量"
  41.             Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  42.             Do While Ex_File <> ""
  43.                 Ex_Date = Replace(Ex_File, "A112", "")                     '消除檔名中"A112"
  44.                 Ex_Date = Replace(Ex_Date, "ALL_1.csv", "")                '消除檔名中"ALL_1.csv"
  45.                 Ex_Date = DateSerial(Mid(Ex_Date, 1, 4), Mid(Ex_Date, 5, 2), Mid(Ex_Date, 7, 2)) '帶入日期
  46.          If .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Ex_File = Dir
  47.          '***  不再重複舊有資料 ****'CD(EX_Date)日期->工作表A欄中找到日期間(有)：離開回圈
  48.          
  49.          
  50.                     Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 A11220070102ALL_1.csv.....
  51.                 '************************************************
  52.                 Ex_Row = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row '取得資料輸入的列號
  53.                 Set Rng = Ex_Wb.Sheets(1).Range("a:a").Find(.Name, lookat:=xlWhole)
  54.                  '.Cells(Ex_Row, "A") = Ex_Date  '日期輸入         '***記錄所有日期***
  55.                 If Not Rng Is Nothing Then
  56.                     .Cells(Ex_Row, "A") = Ex_Date '日期輸入  如移到這裡 '** 只記錄有資料的日期
  57.                     .Cells(Ex_Row, "B") = Rng.Offset(, 8)
  58.                     .Cells(Ex_Row, "e") = Rng.Offset(, 5)
  59.                     .Cells(Ex_Row, "f") = Rng.Offset(, 6)
  60.                     .Cells(Ex_Row, "g") = Rng.Offset(, 7)
  61.                     .Cells(Ex_Row, "i") = Rng.Offset(, 2)
  62.                 End If
  63.                 '************************************************
  64.                 Ex_Wb.Close False                                       '關閉 A11220070102ALL_1.csv.....
  65.       
  66.                 Ex_File = Dir                                               '下一個"A112*ALL_1.csv"
  67.             Loop
  68.         End With
  69.     Next
  70.     Application.ScreenUpdating = True
  71.     MsgBox "OK"
  72. End Sub
複製代碼
那麼

         If .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Ex_File = Dir
         '***  不再重複舊有資料 ****'CD(EX_Date)日期->工作表A欄中找到日期間(有)：離開回圈

該放在哪兒，才能執行成功？

TOP

gkld

帖子
44 
主題
7 
精華
0 
積分
51 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
註冊時間
2012-11-18 
最後登錄
2022-8-6 

論壇贊助勳章
19#
發表於 2013-3-10 18:42 | 只看該作者
回復 18# GBKEE
呀…
板主說的沒有錯，因這行  .Range("a1:ag65536").Clear   '會消除所有的舊資料，我昨晚有把它刪除
試過這樣是可以，昨晚我po的程式碼，忘了把這行改掉，只要將消除所有的舊資料的程式碼那行拿掉，透過用兩個資料夾的方式還是有成功

我現在來試試板的方法看看~

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
18#
發表於 2013-3-10 17:38 | 只看該作者
回復 17# gkld
你的修改可能還是不可以 因這行  .Range("a1:ag65536").Clear   '會消除所有的舊資料
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook
  4.     Dim Rng As Range, Ex_Row As Integer, i As Integer
  5.     Dim Ar() As String, Wb As Workbook
  6.     'Set Wb = Workbooks.Open("D:\股票資料庫.xls")    '開啟股票資料庫的活頁簿
  7.     Ex_Path = "C:\Documents and Settings\gkld\桌面\my kp\資料庫\上市\"
  8.    
  9.     Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  10.     If Ex_File = "" Then
  11.         MsgBox "沒有 A112*ALL_1.csv"
  12.         Exit Sub
  13.     End If
  14.     Application.ScreenUpdating = False
  15.     Ar = Array("台泥", "亞泥", "嘉泥", "幸福", "信大", "東泥")
  16.     Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  17.     Do While Ex_File <> ""
  18.         Ex_Date = Replace(Ex_File, "A112", "")                     '消除檔名中"A112"
  19.         Ex_Date = Replace(Ex_Date, "ALL_1.csv", "")                '消除檔名中"ALL_1.csv"
  20.         Ex_Date = DateSerial(Mid(Ex_Date, 1, 4), Mid(Ex_Date, 5, 2), Mid(Ex_Date, 7, 2)) '帶入日期-> Ex_Date
  21.         For i = 1 To 7
  22.             With Sheets(Ar(i - 1))                                      '指定定陣列中的工作表名稱
  23.             'With Wb.Sheets(Ar(i - 1))                                 '指定定陣列中的工作表不在此程序專案的活頁簿中
  24.                 If Not .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Exit For
  25.                 '***  不再重複舊有資料  ****'CDate(Ex_Date)日期 -> 工作表A欄中 找到日期(有):離開回圈
  26.                 'CDate函數   Date任何可使用的日期運算式。

  28.                 Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 A11220070102ALL_1.csv.....
  29.                 '************************************************
  30.                 Ex_Row = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row '取得資料輸入的列號
  31.                 Set Rng = Ex_Wb.Sheets(1).Range("b:b").Find(.Name, LookAt:=xlWhole)
  32.                  '.Cells(Ex_Row, "A") = Ex_Date  '日期輸入         '** 記錄所有日期***
  33.                 If Not Rng Is Nothing Then
  34.                     .Cells(Ex_Row, "A") = Ex_Date '日期輸入  如移到這裡 '** 只記錄有資料的日期
  35.                     .Cells(Ex_Row, "B") = Rng.Offset(, 7)
  36.                     .Cells(Ex_Row, "e") = Rng.Offset(, 4)
  37.                     .Cells(Ex_Row, "f") = Rng.Offset(, 5)
  38.                     .Cells(Ex_Row, "g") = Rng.Offset(, 6)
  39.                     .Cells(Ex_Row, "i") = Rng.Offset(, 1)
  40.                 End If
  41.             End With
  42.             Ex_Wb.Close False                                       '關閉 A11220070102ALL_1.csv.....
  43.             Ex_File = Dir                                               '下一個"A112*ALL_1.csv"
  44.         Next
  45.     Loop
  46.     Application.ScreenUpdating = True
  47.     MsgBox "OK"
  48. End Sub
複製代碼

TOP

gkld

帖子
44 
主題
7 
精華
0 
積分
51 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
註冊時間
2012-11-18 
最後登錄
2022-8-6 

論壇贊助勳章
17#
發表於 2013-3-9 20:26 | 只看該作者
回復 16# GBKEE
唉呀…板大
我想是我的表達方式讓你誤會成，我只要截取近1週的資料而已
其實是那個股票的資料庫，每天都會有新的資料進來，然後我執行
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook
  4.     Dim Rng As Range, Ex_Row As Integer, i As Integer ', Ar() As String, Ex_Name As String
  5.     Ex_Path = "C:\Documents and Settings\gkld\桌面\my kp\資料庫\上市\"
  6.     Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  7.     If Ex_File = "" Then
  8.         MsgBox "沒有 A112*ALL_1.csv"
  9.         Exit Sub
  10.     End If
  11.     Application.ScreenUpdating = False
  12.     'Ar = Array("台泥", "亞泥", "嘉泥", "幸福", "信大", "東泥")
  13.     For i = 1 To 7
  14.        '** Name 是VBA所用的關鍵字串,避免使用為變數名稱.
  15.        ' If i = 1 Then Ex_Name = "台泥"
  16.        ' If i = 2 Then Ex_Name = "亞泥"
  17.        ' If i = 3 Then Ex_Name = "嘉泥"
  18.        ' If i = 4 Then Ex_Name = "環泥"
  19.        ' If i = 5 Then Ex_Name = "幸福"
  20.        ' If i = 6 Then Ex_Name = "信大"
  21.        ' If i = 7 Then Ex_Name = "東泥"
  22.       
  23.         With Sheets(i)                                                '依工作表索引值指定工作表
  24.         '****工作表名稱 在活頁簿視窗排序如是依IF i=1如此順序***
  25.         '***那就不需這些IF i=1 ...........
  26.       
  27.         'With Sheets(Ex_Name)                                          '依Ex_Name 指定工作表
  28.         '****如在活頁簿視窗工作表名稱排序不是如此順序***
  29.         '***那就需要這些IF i=1 ...........
  30.       
  31.         'With Sheets(Ar(i - 1))                                      '指定定陣列中的工作表名稱
  32.           [s][color=Red]  .Range("a1:ag65536").Clear '消除每一行資料[/color][/s]
  33.             Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  34.             Do While Ex_File <> ""
  35.                 Ex_Date = Replace(Ex_File, "A112", "")                     '消除檔名中"A112"
  36.                 Ex_Date = Replace(Ex_Date, "ALL_1.csv", "")                '消除檔名中"ALL_1.csv"
  37.                 Ex_Date = DateSerial(Mid(Ex_Date, 1, 4), Mid(Ex_Date, 5, 2), Mid(Ex_Date, 7, 2)) '帶入日期
  38.                
  39.                 Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 A11220070102ALL_1.csv.....
  40.                 '************************************************
  41.                 Ex_Row = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row '取得資料輸入的列號
  42.                 Set Rng = Ex_Wb.Sheets(1).Range("b:b").Find(.Name, lookat:=xlWhole)
  43.                  '.Cells(Ex_Row, "A") = Ex_Date  '日期輸入         '** 記錄所有日期***
  44.                 If Not Rng Is Nothing Then
  45.                     .Cells(Ex_Row, "A") = Ex_Date '日期輸入  如移到這裡 '** 只記錄有資料的日期
  46.                     .Cells(Ex_Row, "B") = Rng.Offset(, 7)
  47.                     .Cells(Ex_Row, "e") = Rng.Offset(, 4)
  48.                     .Cells(Ex_Row, "f") = Rng.Offset(, 5)
  49.                     .Cells(Ex_Row, "g") = Rng.Offset(, 6)
  50.                     .Cells(Ex_Row, "i") = Rng.Offset(, 1)
  51.                 End If
  52.                 '************************************************
  53.                 Ex_Wb.Close False                                       '關閉 A11220070102ALL_1.csv.....
  54.                 Ex_File = Dir                                               '下一個"A112*ALL_1.csv"
  55.             Loop
  56.         End With
  57.     Next
  58.     Application.ScreenUpdating = True
  59.     MsgBox "OK"
  60. End Sub
複製代碼
每都都會連同舊的資料一起重抓重跑，時間秏費不少
我想要的結果是之前執行後的舊資料會留著，每當我有一筆新資料進來時，就只要跑新的資料新增就好
因為我vb不好，沒法子像板大一樣，可以寫出比對資料庫裡的data，只把新進來的data抓出來，
後來剛吃晚餐時，突然想到另一個解決方式
我將新的data放進另一個新的資料夾，然後不要消除每一行的資料，即執行以下程式碼
Option Explicit
Sub Ex()
    Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook
    Dim Rng As Range, Ex_Row As Integer, i As Integer ', Ar() As String, Ex_Name As String
    Ex_Path = "C:\Documents and Settings\gkld\桌面\my kp\資料庫\新資料夾\"
    Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
    If Ex_File = "" Then
        MsgBox "沒有 A112*ALL_1.csv"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    'Ar = Array("台泥", "亞泥", "嘉泥", "幸福", "信大", "東泥")
    For i = 1 To 7
       '** Name 是VBA所用的關鍵字串,避免使用為變數名稱.
       ' If i = 1 Then Ex_Name = "台泥"
       ' If i = 2 Then Ex_Name = "亞泥"
       ' If i = 3 Then Ex_Name = "嘉泥"
       ' If i = 4 Then Ex_Name = "環泥"
       ' If i = 5 Then Ex_Name = "幸福"
       ' If i = 6 Then Ex_Name = "信大"
       ' If i = 7 Then Ex_Name = "東泥"
      
        With Sheets(i)                                                '依工作表索引值指定工作表
        '****工作表名稱 在活頁簿視窗排序如是依IF i=1如此順序***
        '***那就不需這些IF i=1 ...........
      
        'With Sheets(Ex_Name)                                          '依Ex_Name 指定工作表
        '****如在活頁簿視窗工作表名稱排序不是如此順序***
        '***那就需要這些IF i=1 ...........
      
        'With Sheets(Ar(i - 1))                                      '指定定陣列中的工作表名稱
            .Range("a1:ag65536").Clear '消除每一行資料
            Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
            Do While Ex_File <> ""
                Ex_Date = Replace(Ex_File, "A112", "")                     '消除檔名中"A112"
                Ex_Date = Replace(Ex_Date, "ALL_1.csv", "")                '消除檔名中"ALL_1.csv"
                Ex_Date = DateSerial(Mid(Ex_Date, 1, 4), Mid(Ex_Date, 5, 2), Mid(Ex_Date, 7, 2)) '帶入日期
               
                Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 A11220070102ALL_1.csv.....
                '************************************************
                Ex_Row = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row '取得資料輸入的列號
                Set Rng = Ex_Wb.Sheets(1).Range("b:b").Find(.Name, lookat:=xlWhole)
                 '.Cells(Ex_Row, "A") = Ex_Date  '日期輸入         '** 記錄所有日期***
                If Not Rng Is Nothing Then
                    .Cells(Ex_Row, "A") = Ex_Date '日期輸入  如移到這裡 '** 只記錄有資料的日期
                    .Cells(Ex_Row, "B") = Rng.Offset(, 7)
                    .Cells(Ex_Row, "e") = Rng.Offset(, 4)
                    .Cells(Ex_Row, "f") = Rng.Offset(, 5)
                    .Cells(Ex_Row, "g") = Rng.Offset(, 6)
                    .Cells(Ex_Row, "i") = Rng.Offset(, 1)
                End If
                '************************************************
                Ex_Wb.Close False                                       '關閉 A11220070102ALL_1.csv.....
                Ex_File = Dir                                               '下一個"A112*ALL_1.csv"
            Loop
        End With
    Next
    Application.ScreenUpdating = True
    MsgBox "OK"
End Sub
好像也可以解決
唉…只能用笨方法了

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
16#
發表於 2013-3-9 13:42 | 只看該作者
回復 15# gkld
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook, ar
  4.     Dim Rng As Range, Ex_Row As Integer, i As Integer ', Ar() As String, Ex_Name As String
  5.     Ex_Path = "C:\Documents and Settings\gkld\桌面\my kp\資料庫\上市\"
  6.     Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  7.     If Ex_File = "" Then
  8.         MsgBox "沒有 A112*ALL_1.csv"
  9.         Exit Sub
  10.     End If
  11.     Application.ScreenUpdating = False
  12.     ar = Array("台泥", "亞泥", "嘉泥", "幸福", "信大", "東泥")
  13.     For i = 1 To 7
  14.         With Sheets(ar(i - 1))                                      '指定定陣列中的工作表名稱
  15.             .Range("a1:ag65536").Clear '消除每一行資料
  16.             Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
  17.             Do While Ex_File <> ""
  18.                 Ex_Date = Replace(Ex_File, "A112", "")                     '消除檔名中"A112"
  19.                 Ex_Date = Replace(Ex_Date, "ALL_1.csv", "")                '消除檔名中"ALL_1.csv"
  20.                 Ex_Date = DateSerial(Mid(Ex_Date, 1, 4), Mid(Ex_Date, 5, 2), Mid(Ex_Date, 7, 2)) '帶入日期
  21.                 '*****設下日期條件 一周內的日期
  22.                 If CDate(Ex_Date) + 6 >= Date Then
  23.                     Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 A11220070102ALL_1.csv.....
  24.                     Ex_Row = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row '取得資料輸入的列號
  25.                     Set Rng = Ex_Wb.Sheets(1).Range("b:b").Find(.Name, lookat:=xlWhole)
  26.                     '.Cells(Ex_Row, "A") = Ex_Date  '日期輸入         '** 記錄所有日期***
  27.                     If Not Rng Is Nothing Then
  28.                         .Cells(Ex_Row, "A") = Ex_Date '日期輸入  如移到這裡 '** 只記錄有資料的日期
  29.                         .Cells(Ex_Row, "B") = Rng.Offset(, 7)
  30.                         .Cells(Ex_Row, "e") = Rng.Offset(, 4)
  31.                         .Cells(Ex_Row, "f") = Rng.Offset(, 5)
  32.                         .Cells(Ex_Row, "g") = Rng.Offset(, 6)
  33.                         .Cells(Ex_Row, "i") = Rng.Offset(, 1)
  34.                     End If
  35.                     Ex_Wb.Close False                                       '關閉 A11220070102ALL_1.csv.....
  36.                 End If   '*****  一周內的日期
  37.                 Ex_File = Dir                                               '下一個"A112*ALL_1.csv"
  38.             Loop
  39.         End With
  40.     Next
  41.     Application.ScreenUpdating = True
  42.     MsgBox "OK"
  43. End Sub
複製代碼

TOP

gkld

帖子
44 
主題
7 
精華
0 
積分
51 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
註冊時間
2012-11-18 
最後登錄
2022-8-6 

論壇贊助勳章
15#
發表於 2013-3-8 19:24 | 只看該作者
回復 11# GBKEE
請問板大…
您的這個方式，我用了一陣子
後來發現，如果我有幾筆新最近日期的資料，如A11220130307ALL_1.csv…要放入股票資料庫裡，
執行您教的這個vba的話，它會整個從資料庫裡的每筆舊日期資料重新跑過，挑出來重新排列
這樣很浪費時間
有辦法執行vba的時候，不用再去抓舊日期的資料，只對新筆資料做新增出來作為每日歷史股價嗎？感恩

TOP

        靜思自在 : 靜坐常恩己過、閒談莫論人非。
123
返回列表 上一主題