個人積分：0分
文章編號：71755995
我用你所說的將檔案的CSV 存起來, 再排版, 但在"OCT market"這個網址, 卻反應過時, 我真的不知道是何原因, 不知道 前輩可不可以撥空幫我RUN 看看, 先謝謝您了.
以下是程式碼:
=============================================================
Option Explicit
Sub Auto_Open()
Dim ExChanger()
Dim Exx, MyUrl, MySht, Key
Dim RngKey, RngSearch As Range
MySht = Array("Temp", "NYSE", "OTC", "原始")
Call 處理Sheet(MySht)
'Application.ScreenUpdating = False
'主要市場資料
'------------------------------------------------------
Sheets(MySht(0)).Select
ExChanger = Array("NYSE", "AMEX", "Nasdaq", "SCAP")
For Each Exx In ExChanger
MyUrl = "http://www.wsj.com/public/resources/documents/" & Exx & ".csv"
Call url2CSV2Array2cell(MyUrl, Exx)
Next
'------------------
Key = "Symbol"
Range("A1").Select
Cells.Find(What:=Key, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Select
Set RngKey = Selection
Rows("1:" & Selection.Row - 1).Delete
Columns(Selection.Column).Select
Selection.Cut
Selection.Offset(, -1).Select
Selection.Insert Shift:=xlToRight
'以Symbol排序
Rows("1:65536").Select
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=RngKey _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
.SetRange Selection
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'殺多餘的Symbol
Set RngSearch = Range(Range("b2"), Range("B65536"))
Do
Err.Clear: On Error Resume Next
RngSearch.Find(Key).Select
If Err.Number = 0 Then
Rows(Selection.Row).Delete
Else
Err.Number = 0
Exit Do
End If
Loop
'------------------------------------------------------------------------------
'移到原始sheet
Range("a1").CurrentRegion.Select
Selection.Copy Sheets(MySht(3)).Cells(65536, 1).End(xlUp).Offset(1)
Stop
'以下的網址會出珼反應過時的問題.
'========================================================================
'OTC市場資料
'=========================================================================================
Stop
Exx = "Stock_Screener"
MyUrl = "https://www.otcmarkets.com/research/stock-screener/api/downloadCSV/" & Exx & ".csv"
Call url2CSV2Array2cell(MyUrl, Exx)
'MyUrl = "https://www.otcmarkets.com/research/stock-screener/api/downloadCSV/Stock_Screener.csv"
'Call url2CSV2Array2cell(MyUrl, "OTC")
ThisWorkbook.Save
Application.ScreenUpdating = True
Application.StatusBar = False
Excel.Application.Quit
End Sub
Sub url2CSV2Array2cell(MyUrl, Exx)
Dim CSV_N, Doc As String
Dim oStream As Object
Set oStream = CreateObject("ADODB.Stream")
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
With WinHttpReq
.Open "GET", MyUrl, False
.Send
End With
CSV_N = ThisWorkbook.Path & "\" & Exx & ".csv"
'MyUrl = WinHttpReq.ResponseBody
If WinHttpReq.Status = 200 Then
With oStream
.Open
.Type = 1
.Write WinHttpReq.ResponseBody
.SaveToFile CSV_N, 2
.Close
End With
End If
Dim MyData As String, strData() As String, TmpAr() As String
Dim TwoDArray() As String
Dim i, j As Long, m, n As Long
Dim t, ttt
Open CSV_N For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, Chr(10))
For j = LBound(strData) To UBound(strData)
If InStr(strData(j), "Name") > 0 Then Exit For
Next
m = 0
ReDim Preserve TwoDArray(UBound(strData), 20)
For i = j To UBound(strData)
n = 0
'Debug.Print strData(i)
If Len(Trim(strData(i))) <> 0 Then
'Debug.Print strData(i)
TmpAr = Split(strData(i), ",")
m = m + 1
TwoDArray(m, 0) = Exx
For Each t In TmpAr
'Debug.Print t
n = n + 1
'~~> TmpAr(1) : 1 for Col B, 0 would be A
TwoDArray(m, n) = t
Next t
End If
Next i
With Sheets("Temp").Cells(65536, 1).End(xlUp).Offset(1)
.Resize(UBound(TwoDArray, 1), UBound(TwoDArray, 2)) = TwoDArray
End With
End Sub
Sub 處理Sheet(MySht)
'加一個Tang, 其餘砍掉
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Tang"
For Each s In Worksheets
s.Select
Application.DisplayAlerts = False
If ActiveSheet.Name <> "Tang" Then
ActiveSheet.Delete
End If
Next s
For Each s In MySht
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = s
Next
Set Rput = Range("A1")
Sheets("Tang").Delete
Application.DisplayAlerts = True
End Sub
個人積分：2598分
文章編號：71761652
個人積分：0分
文章編號：71764876
個人積分：1176分
文章編號：71768869
snare wrote:
您參考 271 樓、272 樓，自行改寫過的程式碼是錯的，無法下載資料，從這行開始就有問題了
startday = DateAdd("yyyy", -1, endday)
snare大，
我不是很懂您的意思「從這行開始就有問題了…」
因為我執行時都可正常下載…
snare wrote:
改寫 271 樓、272 樓範例時，請把 On Error Resume Next 這行，暫時禁用
使用 f8 逐行執行，多多利用 debug.print、區域變數視窗，來偵錯
請自行練習
感謝snare大的提醒！
=====================================================
我把VBA codes再修一修，順便加上判斷是否有多餘的*.h檔並行除。
再來要來研究圖表的VBA要怎麼寫了～
=====================================================
Sub Test_memory()
Dim Xmlhttp As Object, lastrow As Integer, FileName As String, Url As String, Crumbkey As String, Stock As String, startday As String, endday As String, TryAgain As Integer, ErrorStock As String
Set Clipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Dim endday_UnixTime As Long, startday_UnixTime As Long
Dim HisSheetName As String, wsSheet As Worksheet
Dim wsSheetFound As Worksheet
Dim strfound, waitdel, strHisSheetName As String
Application.DisplayAlerts = False
Application.StatusBar = True
ttt = Timer
'On Error Resume Next
Sheets("US.Stock").Activate
Sheets("US.Stock").Columns(9).Clear
Sheets("US.Stock").Cells(1, 11) = ""
Sheets("US.Stock").Range(Cells(2, 2), Cells(100, 8)).Value = ""
endday = Date '目前日期
'Debug.Print "EndDay = " & endday
startday = DateAdd("yyyy", -1, endday) '往前1年
'startday = DateAdd("m", -9, endday)
'Debug.Print "StartDay = " & startday
lastrow = Sheets("US.Stock").Range("a1").CurrentRegion.Rows.Count
'Debug.Print "lastrow = " & lastrow
Set Xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
With Xmlhttp
.Open "GET", "https://finance.yahoo.com/quote/VTI/history?p=VTI", False
.send
Crumbkey = Left(Split(.responsetext, """CrumbStore"":{""crumb"":""")(1), 11)
'Debug.Print "Crumbkey = " & Crumbkey
For i = 2 To lastrow
FileName = ""
Stock = Sheets("US.Stock").Cells(i, 1).Value
'Debug.Print "Stock = " & Stock
Application.StatusBar = "Downloading: " & Stock & " history data. Total %: " & Round((i / lastrow) * 100, 0) & "%"
Application.ScreenUpdating = False
Url = "https://query1.finance.yahoo.com/v7/finance/download/" & Stock & "?period1=" & DataToUnixTime(startday) & "&period2=" & DataToUnixTime(endday) & "&interval=1d&events=history&crumb="
.Open "POST", Url & Crumbkey, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
FileName = Split(.getresponseheader("Content-Disposition"), "filename=")(1)
'Debug.Print "FileName = " & FileName
With Clipboard
.SetText Xmlhttp.responsetext
.PutInClipboard
End With
HisSheetName = Stock & ".h"
'Debug.Print "HisSheetName = " & HisSheetName
On Error Resume Next
Set wsSheet = Sheets(HisSheetName)
On Error GoTo 0
If Not wsSheet Is Nothing Then
Set wsSheet = Nothing
Else
Sheets.Add(After:=Sheets(Sheets.Count)).Name = HisSheetName
End If
Sheets(HisSheetName).Activate
If FileName <> "" And InStr(.responsetext, "Encountered an error") = 0 Then
j = j + 1
With ActiveSheet
.Cells(1, 1).Select
.PasteSpecial NoHTMLFormatting:=True
.Columns("A:A").TextToColumns DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Comma:=True
.Cells.EntireColumn.AutoFit
.Cells(1, 1).End(xlToRight).End(xlDown).Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlYes
Columns("A:A").EntireColumn.Select
Selection.NumberFormatLocal = "yyyy-mm-dd"
Columns("B:F").EntireColumn.Select
Selection.NumberFormatLocal = "#,##0.00"
End With
Else
Sheets("US.Stock").Cells(i, 8) = "error"
TryAgain = TryAgain + 1
ErrorStock = ErrorStock & Sheets("US.Stock").Cells(i, 1) & vbNewLine
End If
Worksheets(HisSheetName).Range(Cells(2, 1), Cells(2, 7)).Copy
Worksheets("US.Stock").Cells(i, 2).PasteSpecial xlPasteValues
DoEvents
Application.ScreenUpdating = True
Sheets("US.Stock").Cells(1, 11) = Round((i / lastrow) * 100, 2) & "%"
strHisSheetName = strHisSheetName & HisSheetName & " "
Next i
Sheets("US.Stock").Activate
'Debug.Print "TryAgain = " & TryAgain
MsgBox "成功下載" & (lastrow - 1 - TryAgain) & "筆，完成度" & Round(((lastrow - TryAgain) / lastrow) * 100, 2) & "%" & _
vbNewLine & "使用時間" & Timer - ttt & "秒" & _
vbNewLine & "以下" & TryAgain & "筆需重新下載或股票代號輸入錯誤" & _
vbNewLine & ErrorStock, vbOKOnly, "Report"
End With
Set Xmlhttp = Nothing
Set Clipboard = Nothing
Set wsSheet = Nothing
Application.StatusBar = False
For Each wsSheetFound In Worksheets
If wsSheetFound.Name Like "*.h" Then
strfound = strfound & wsSheetFound.Name & vbCrLf
'Debug.Print "strfound = " & strfound
'Debug.Print "strHisSheetName = " & strHisSheetName
'Debug.Print "wsSheetFound.Name = " & wsSheetFound.Name
If InStr(1, strHisSheetName, wsSheetFound.Name, vbTextCompare) = 0 Then
waitdel = waitdel & wsSheetFound.Name & vbCrLf
'Debug.Print "waitdel = " & waitdel
wsSheetFound.Delete
End If
End If
Next wsSheetFound
MsgBox "存在的 *.h 工作表有：" & vbCrLf & strfound
If waitdel = "" Then
MsgBox "刪除的多餘的 *.h 工作表有：無"
Else
MsgBox "刪除的多餘 *.h 工作表有：" & vbCrLf & waitdel
End If
Application.DisplayAlerts = True
End Sub
Function DataToUnixTime(dstring) As Long
DataToUnixTime = (DateValue(dstring) - #1/1/1970 8:00:00 AM#) * 86400
End Function
附加壓縮檔: 201901/mobile01-818b25bf5bc9e9e864ad7977efda81b4.zip
蔬食抗暖化，減碳救地球！
個人積分：2598分
文章編號：71772800
tang7325 wrote:
繞了一個彎就會刁到, 不知道前輩有何建議, 如何能培養成可以識破他的能力?...(恕刪)
多練習，久了就會了
下載檔案通常就這3種
www.abc.com 下載，網址改變 www.abc.com/d.csv
www.abc.com 下載，網址不變 www.abc.com 出現檔名 d.csv
www.abc.com 下載，連到別的網址 www.efg.com，再下載 d.csv
nijawang wrote:
我不是很懂您的意思「從這行開始就有問題了…」
因為我執行時都可正常下載…...(恕刪)
您大概是用舊版的excel吧??
新版(x64)用dateadd() + string 會出問題(如圖)
使用標準日期格式，建議把程式碼做小部份修改，可避免相容性的問題
startday As string, endday As string
改成
startday As Date, endday As Date
Function DataToUnixTime(dstring) As Long
DataToUnixTime = (DateValue(dstring) - #1/1/1970 8:00:00 AM#) * 86400
End Function
改成
Function DataToUnixTime(dstring As Date) As Long
DataToUnixTime = (dstring - #1/1/1970 8:00:00 AM#) * 86400
End Function
個人積分：1176分
文章編號：71780573
snare wrote:
您大概是用舊版的 excel 吧??
新版 (x64) 用 dateadd() + string 會出問題 (如圖)...(恕刪)
平常在用的都是Excel 2013(x32)英文版。
剛才試了Excel 2016(x64)中文版，也沒有出現您說的問題。
不過倒是出了個PasteSpecial的問題！？
不知道是哪裡出問題…
snare wrote:
使用標準日期格式，建議把程式碼做小部份修改，可避免相容性的問題
startday As string, endday As string
改成
startday As Date, endday As Date...(恕刪)
對吼！
我竟然忘了改變數型態。
感謝！
蔬食抗暖化，減碳救地球！
個人積分：2598分
文章編號：71781673
個人積分：1176分
文章編號：71781980
個人積分：0分
文章編號：71807621
============================================
Sub getstock()
Dim URL, HTMLsourcecode,GetXml
Set HTMLsourcecode = CreateObject("htmlfile")
Set GetXml=CreateObject("msxml2.xmlhttp")
'範例網址yahoo 中華電信 股價
URL = "https://tw.stock.yahoo.com/q/q?s=2412"
==========================================================
我嘗試試用上述的程式碼,但卻在"createobject("htmlfile")"的地方出現錯誤,
錯誤:429ActiveX 元件無法產生物件
環境:win7 sp1 office 2007 SP3
不知, 我還要作什麼的設定?
Tang7325
個人積分：2598分
文章編號：71815580
關閉廣告