返回列表 上一主題 發帖

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

回復 1# gkld
ActiveSheet  '作用中的工作表
是為圖2 中 造紙類指數
  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.     Ex_Path = "資料夾路徑\"                         '******修改它********
  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.     Do While Ex_File <> ""
  12.         Ex_Date = Replace(Ex_File, "A112", "")                     '消除檔名中"A112"
  13.         Ex_Date = Replace(Ex_Date, "ALL_1.csv", "")                '消除檔名中"ALL_1.csv"
  14.         Ex_Date = DateSerial(Mid(Ex_Date, 1, 4), Mid(Ex_Date, 5, 2), Mid(Ex_Date, 7, 2)) '帶入日期
  15.         With ActiveSheet                                            '作用中的工作表
  16.             Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 A11220070102ALL_1.csv.....
  17.             .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = Ex_Date  '日期輸入
  18.             .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("A:A").Find(.Range("B1"), lookat:=xlWhole).Offset(, 1)
  19.             '**** 作用中的工作表.Range("B1") 為查詢指數的類別  *********
  20.             Ex_Wb.Close                                             '關閉 A11220070102ALL_1.csv.....
  21.         End With
  22.         Ex_File = Dir                                               '下一個"A112*ALL_1.csv"
  23.     Loop
  24.     Application.ScreenUpdating = True
  25.     MsgBox "OK"
  26. End Sub
複製代碼

TOP

回復 5# gkld
主要是為了抓取資料庫中每個csv的range("b12")值  
  1. .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("B12")
複製代碼

TOP

回復 7# 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
  5.     Ex_Path = "資料夾路徑\"                         '******修改它********
  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.     Do While Ex_File <> ""
  13.         Ex_Date = Replace(Ex_File, "A112", "")                     '消除檔名中"A112"
  14.         Ex_Date = Replace(Ex_Date, "ALL_1.csv", "")                '消除檔名中"ALL_1.csv"
  15.         Ex_Date = DateSerial(Mid(Ex_Date, 1, 4), Mid(Ex_Date, 5, 2), Mid(Ex_Date, 7, 2)) '帶入日期
  16.         With ActiveSheet                                            '作用中的工作表
  17.             Set Ex_Wb = Workbooks.Open(Ex_Path & Ex_File)           '開啟 A11220070102ALL_1.csv.....
  18.             '************************************************
  19.             .Cells(.Rows.Count, "A").End(xlUp).Offset(1) = Ex_Date  '日期輸入
  20.             If Ex_Wb.Sheets(1).Range("B12") <> "" Then
  21.                 .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = Ex_Wb.Sheets(1).Range("B12")
  22.             Else
  23.                 .Cells(.Rows.Count, "B").End(xlUp).Offset(1) = "---"   '**沒有資料
  24.                 '**** 作用中的工作表.Range("B1") 為查詢指數的類別  *********
  25.             End If
  26.             '************************************************
  27.             Ex_Wb.Close False                                       '關閉 A11220070102ALL_1.csv.....
  28.         End With
  29.         Ex_File = Dir                                               '下一個"A112*ALL_1.csv"
  30.     Loop
  31.     Application.ScreenUpdating = True
  32.     MsgBox "OK"
  33. End Sub
複製代碼

TOP

回復 10# 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 ', 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.             .Range("a1:ag65536").Clear '消除每一行資料
  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
複製代碼

TOP

回復 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

回復 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任何可使用的日期運算式。

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

TOP

本帖最後由 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 條件式

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

TOP

        靜思自在 : 【停滯不前,終無所得】人都迷於尋找奇蹟,因而停滯不前;縱使時間再多、路再長,也了無用處,終無所得。
返回列表 上一主題