麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 請問如果有一個股票資料庫，如何使用vba… [打印本頁]

作者: gkld 時間: 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檔，每個檔案打開
如圖[attach]13696[/attach]
現在我想要從這個資料庫內整裡出不同日期的歷史股價，格式如圖 [attach]13697[/attach]
請問如何用vba寫出來了呢？救救我吧~謝謝大家~

作者: GBKEE 時間: 2012-12-27 09:44

回復 1# gkld
ActiveSheet '作用中的工作表
是為圖2 中造紙類指數

Option Explicit
Sub Ex()
Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook
Ex_Path = "資料夾路徑\" '******修改它********
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
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)) '帶入日期
With ActiveSheet '作用中的工作表
Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File) '開啟 A11220070102ALL_1.csv.....
.Cells(.Rows.Count, "A").End(xlUp).Offset(1) = Ex_Date '日期輸入
.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("A:A").Find(.Range("B1"), lookat:=xlWhole).Offset(, 1)
'**** 作用中的工作表.Range("B1") 為查詢指數的類別 *********
Ex_Wb.Close '關閉 A11220070102ALL_1.csv.....
End With
Ex_File = Dir '下一個"A112*ALL_1.csv"
Loop
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

複製代碼

作者: gkld 時間: 2012-12-27 12:52

回復 2# GBKEE

感謝…版大，現在正在上班中…;P

回家再來試試看~

作者: gkld 時間: 2012-12-27 13:02

回復 3# gkld

另外，最近自已上網看了一些有關vba的簡單教學，發現這真是一個很實用的工具

   其應用範圍真的很廣泛。

   想請教版大…，如果想要學習的話，有推薦的書單嗎？

作者: gkld 時間: 2012-12-27 14:46

回復 4# gkld

請問板大：
我跑出來的結果是，如圖[attach]13706[/attach]

我有將第18行程式碼改成如下，主要是為了抓取資料庫中每個csv的range("b12")值

.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("A:A").Find(.Range("B12"), lookat:=xlWhole).Offset(, 1)

不曉得錯在哪兒？求助板大指導。感恩~

作者: GBKEE 時間: 2012-12-27 16:06

回復 5# gkld
主要是為了抓取資料庫中每個csv的range("b12")值

.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("B12")

複製代碼

作者: gkld 時間: 2012-12-27 20:39

回復 6# GBKEE

奇怪~出來的結果應該是會取到每個csv的range("b12")，怎麼出來還是不對？？[attach]13709[/attach]

附件是我的資料庫[attach]13710[/attach][attach]13711[/attach]

可以請版大再次解惑嗎？感謝

作者: GBKEE 時間: 2012-12-27 21:07

回復 7# gkld

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_Path = "資料夾路徑\" '******修改它********
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
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)) '帶入日期
With ActiveSheet '作用中的工作表
Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File) '開啟 A11220070102ALL_1.csv.....
'************************************************
.Cells(.Rows.Count, "A").End(xlUp).Offset(1) = Ex_Date '日期輸入
If Ex_Wb.Sheets(1).Range("B12") <> "" Then
.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("B12")
Else
.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = "---" '**沒有資料
'**** 作用中的工作表.Range("B1") 為查詢指數的類別 *********
End If
'************************************************
Ex_Wb.Close False '關閉 A11220070102ALL_1.csv.....
End With
Ex_File = Dir '下一個"A112*ALL_1.csv"
Loop
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

複製代碼

作者: gkld 時間: 2012-12-28 21:43

回復 8# GBKEE

今天回來測試，結果沒問題~

感謝板大鼎力相助

接著自已就可以簡單地去變換相抓取的儲存格了!!:D

作者: gkld 時間: 2012-12-28 23:25

回復 9# gkld
再請教一個問題，我例用板大教的方式，跑出第一個1101台泥工作表[attach]13724[/attach]，程式碼如下：

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_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
Range("a1:ag65536").Clear '消除每一行資料
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)) '帶入日期
With ActiveSheet '作用中的工作表
Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File) '開啟 A11220070102ALL_1.csv.....
'************************************************
.Cells(.Rows.Count, "A").End(xlUp).Offset(1) = Ex_Date '日期輸入
If Ex_Wb.Sheets(1).Range("B3") <> "" Then
.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find("台泥", lookat:=xlWhole).Offset(, 7)
.Cells(.Rows.Count, "e").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find("台泥", lookat:=xlWhole).Offset(, 4)
.Cells(.Rows.Count, "f").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find("台泥", lookat:=xlWhole).Offset(, 5)
.Cells(.Rows.Count, "g").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find("台泥", lookat:=xlWhole).Offset(, 6)
.Cells(.Rows.Count, "i").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find("台泥", lookat:=xlWhole).Offset(, 1)
Else
.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = "---" '**沒有資料
.Cells(.Rows.Count, "e").End(xlUp).Offset(1) = "---" '**沒有資料
.Cells(.Rows.Count, "f").End(xlUp).Offset(1) = "---" '**沒有資料
.Cells(.Rows.Count, "g").End(xlUp).Offset(1) = "---" '**沒有資料
.Cells(.Rows.Count, "i").End(xlUp).Offset(1) = "---" '**沒有資料
'**** 修改作用中的工作表.Range("B1") 為查詢指數的類別 *********
End If
'************************************************
Ex_Wb.Close False '關閉 A11220070102ALL_1.csv.....
End With
Ex_File = Dir '下一個"A112*ALL_1.csv"
Loop
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

複製代碼

後來，我想在新增好幾個工作表，如1102亞泥；1103嘉泥；…等一直到1110東泥，共7個工作表

程式碼如下：

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_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
Range("a1:ag65536").Clear '消除每一行資料
For i = 1 To 7
If i = 1 Then Name = "台泥"
End If
If i = 2 Then Name = "亞泥"
End If
If i = 3 Then Name = "嘉泥"
End If
If i = 4 Then Name = "環泥"
End If
If i = 5 Then Name = "幸福"
End If
If i = 6 Then Name = "信大"
End If
If i = 7 Then Name = "東泥"
End If
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)) '帶入日期
With ActiveSheet '作用中的工作表
Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File) '開啟 A11220070102ALL_1.csv.....
'************************************************
.Cells(.Rows.Count, "A").End(xlUp).Offset(1) = Ex_Date '日期輸入
If Ex_Wb.Sheets(1).Range("B3") <> "" Then
Sheet(i).Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find(Name, lookat:=xlWhole).Offset(, 7)
Sheet(i).Cells(.Rows.Count, "e").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find(Name, lookat:=xlWhole).Offset(, 4)
Sheet(i).Cells(.Rows.Count, "f").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find(Name, lookat:=xlWhole).Offset(, 5)
Sheet(i).Cells(.Rows.Count, "g").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find(Name, lookat:=xlWhole).Offset(, 6)
Sheet(i).Cells(.Rows.Count, "i").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("b:b").Find(Name, lookat:=xlWhole).Offset(, 1)
Else
.Cells(.Rows.Count, "B").End(xlUp).Offset(1) = "---" '**沒有資料
.Cells(.Rows.Count, "e").End(xlUp).Offset(1) = "---" '**沒有資料
.Cells(.Rows.Count, "f").End(xlUp).Offset(1) = "---" '**沒有資料
.Cells(.Rows.Count, "g").End(xlUp).Offset(1) = "---" '**沒有資料
.Cells(.Rows.Count, "i").End(xlUp).Offset(1) = "---" '**沒有資料
'**** 修改作用中的工作表.Range("B1") 為查詢指數的類別 *********
End If
'************************************************
Ex_Wb.Close False '關閉 A11220070102ALL_1.csv.....
End With
Ex_File = Dir '下一個"A112*ALL_1.csv"
Loop
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

複製代碼

用很笨拙的方式去寫，卻跑不出結果來，出現錯誤…，可以請板大撥空幫我看看嗎？

作者: GBKEE 時間: 2012-12-29 08:34

回復 10# gkld

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

複製代碼

作者: gkld 時間: 2012-12-29 20:44

熱心的板大：

怎麼會出現『編譯錯誤，有next卻沒有for』的對話方塊？

我一條一條看程式碼，明明就有for嗎？不就是for i=1 to 7，第13行那兒嗎？

作者: gkld 時間: 2012-12-29 22:49

回復 12# gkld
不好意思…板大…我找到原因了
是我將程式碼日了些東西-____-#
現在改回來，測試沒問題了~
哈哈哈…開心~
感恩丫!!
繼續研究研究 :)

作者: gkld 時間: 2012-12-29 23:24

回復 13# gkld
上傳做好的個股資料圖片，供像我一樣的新手參考[attach]13729[/attach]
另外提供所談到的資料圖程式[attach]13730[/attach]
當然小弟沒有那麼厲害，想當然也是網路上熱心的先進們提供，
雖然日期部分得手動keyin，不過我個人已覺得很滿足了
只要再將板大的指導加進去所得，就可以做出每檔個股歷史資料啦!!

作者: gkld 時間: 2013-3-8 19:24

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

作者: GBKEE 時間: 2013-3-9 13:42

回復 15# gkld
試試看

Option Explicit
Sub Ex()
Dim Ex_Path As String, Ex_File As String, Ex_Date As String, Ex_Wb As Workbook, ar
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
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)) '帶入日期
'*****設下日期條件一周內的日期
If CDate(Ex_Date) + 6 >= Date Then
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.....
End If '***** 一周內的日期
Ex_File = Dir '下一個"A112*ALL_1.csv"
Loop
End With
Next
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

複製代碼

作者: gkld 時間: 2013-3-9 20:26

回復 16# GBKEE
唉呀…板大
我想是我的表達方式讓你誤會成，我只要截取近1週的資料而已
其實是那個股票的資料庫，每天都會有新的資料進來，然後我執行

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)) '指定定陣列中的工作表名稱
[s][color=Red] .Range("a1:ag65536").Clear '消除每一行資料[/color][/s]
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

複製代碼

每都都會連同舊的資料一起重抓重跑，時間秏費不少
我想要的結果是之前執行後的舊資料會留著，每當我有一筆新資料進來時，就只要跑新的資料新增就好
因為我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
好像也可以解決
唉…只能用笨方法了

作者: GBKEE 時間: 2013-3-10 17:38

回復 17# gkld
你的修改可能還是不可以因這行 .Range("a1:ag65536").Clear '會消除所有的舊資料
試試看

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
Dim Ar() As String, Wb As Workbook
'Set Wb = Workbooks.Open("D:\股票資料庫.xls") '開啟股票資料庫的活頁簿
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("台泥", "亞泥", "嘉泥", "幸福", "信大", "東泥")
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)) '帶入日期-> Ex_Date
For i = 1 To 7
With Sheets(Ar(i - 1)) '指定定陣列中的工作表名稱
'With Wb.Sheets(Ar(i - 1)) '指定定陣列中的工作表不在此程序專案的活頁簿中
If Not .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Exit For
'*** 不再重複舊有資料 ****'CDate(Ex_Date)日期 -> 工作表A欄中找到日期(有):離開回圈
'CDate函數 Date任何可使用的日期運算式。
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
End With
Ex_Wb.Close False '關閉 A11220070102ALL_1.csv.....
Ex_File = Dir '下一個"A112*ALL_1.csv"
Next
Loop
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

複製代碼

作者: gkld 時間: 2013-3-10 18:42

回復 18# GBKEE
呀…
板主說的沒有錯，因這行 .Range("a1:ag65536").Clear '會消除所有的舊資料，我昨晚有把它刪除
試過這樣是可以，昨晚我po的程式碼，忘了把這行改掉，只要將消除所有的舊資料的程式碼那行拿掉，透過用兩個資料夾的方式還是有成功

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

作者: gkld 時間: 2013-3-10 20:37

回復 18# GBKEE
板大…如果程式碼如下

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\資料庫\old 上市\"
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 = 2 To 8
'** 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("m1:ag65536").Clear '消除每一行資料
.Range("a1") = "日期" '製作表頭
.Range("b1") = "收盤"
.Range("c1") = "漲跌"
.Range("d1") = "漲跌率"
.Range("e1") = "開盤"
.Range("f1") = "最高"
.Range("g1") = "最低"
.Range("h1") = "成交量(單位)"
.Range("i1") = "成交量"
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)) '帶入日期
If .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Ex_File = Dir
'*** 不再重複舊有資料 ****'CD(EX_Date)日期->工作表A欄中找到日期間(有)：離開回圈
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("a:a").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(, 8)
.Cells(Ex_Row, "e") = Rng.Offset(, 5)
.Cells(Ex_Row, "f") = Rng.Offset(, 6)
.Cells(Ex_Row, "g") = Rng.Offset(, 7)
.Cells(Ex_Row, "i") = Rng.Offset(, 2)
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

複製代碼

那麼

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

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

作者: gkld 時間: 2013-3-10 21:09

回復 20# gkld

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
Ex_Path = "C:\Documents and Settings\gkld\桌面\my kp\資料庫\old 上市\"
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
For i = 2 To 8
With Sheets(i)
.Range("a1") = "日期" '製作表頭
.Range("b1") = "收盤"
.Range("c1") = "漲跌"
.Range("d1") = "漲跌率"
.Range("e1") = "開盤"
.Range("f1") = "最高"
.Range("g1") = "最低"
.Range("h1") = "成交量(單位)"
.Range("i1") = "成交量"
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)) '帶入日期
If Not .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Exit For
'*** 不再重複舊有資料 ****'CDate(Ex_Date)日期 -> 工作表A欄中找到日期(有):離開回圈
'CDate函數 Date任何可使用的日期運算式。
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("a:a").Find(.Name, LookAt:=xlWhole)
If Not Rng Is Nothing Then
.Cells(Ex_Row, "A") = Ex_Date '日期輸入如移到這裡 '** 只記錄有資料的日期
.Cells(Ex_Row, "B") = Rng.Offset(, 8)
.Cells(Ex_Row, "e") = Rng.Offset(, 5)
.Cells(Ex_Row, "f") = Rng.Offset(, 6)
.Cells(Ex_Row, "g") = Rng.Offset(, 7)
.Cells(Ex_Row, "i") = Rng.Offset(, 2)
End If
'************************************************
Ex_Wb.Close False '關閉 A11220070102ALL_1.csv.....
' End If '*****一周內的日期
Ex_File = Dir '下一個"A112*ALL_1.csv"
Loop
End With
Next
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

複製代碼

放的位置如上，我執行的時候，就直接跳出我的i=2 to 8 這個回圈了

該如何解決？

作者: GBKEE 時間: 2013-3-11 08:22

本帖最後由 GBKEE 於 2013-3-11 08:25 編輯

回復 21# gkld
說明18#程式碼編寫的邏輯

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
Dim Ar() As String, Wb As Workbook
'Set Wb = Workbooks.Open("D:\股票資料庫.xls") '開啟股票資料庫的活頁簿
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("台泥", "亞泥", "嘉泥", "幸福", "信大", "東泥")
Ex_File = Dir(Ex_Path & "A112*ALL_1.csv")
Do While Ex_File <> "" ' 尋找 *.csv 的迴圈
'.............簡略
For i = 1 To 7 '工作表的迴圈
With Sheets(Ar(i - 1)) '指定定陣列中的工作表名稱
'.............簡略
If Not .Columns(1).Find(CDate(Ex_Date), LookIn:=xlFormulas) Is Nothing Then Exit For
'If Not .Columns(1).Find 迴圈比對在工作表中比對日期的 If 條件式
'Exit For:離開For i = 1 To 7 這回圈:不再重複舊有的資料
Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File) '開啟不存日期的.csv.....
'.............簡略
End With
Ex_Wb.Close False '關閉 A11220070102ALL_1.csv.....
Next
'**************************************
Ex_File = Dir '下一個"A112*ALL_1.csv"
'PS 18# 的程式碼有錯誤: 18# 43行程式碼 Ex_File = Dir 須移到 Loop 的前一行繼續找下一個"A112*ALL_1.csv"
Loop
'**************************************
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

複製代碼

作者: gkld 時間: 2013-3-11 21:34

回復 22# GBKEE
ok~:D
我已修正完成~
感謝板大細心指導!!

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