Excel VBA 抓取上市櫃股票代號

很基本的東西，但卻意外地難找到資料源

今天好不容易找到一個蠻不錯的資料源
直接寫進程式碼


抓股票代號:

	Sub 股票代號()
	Application.StatusBar = "下載中"
	Dim t: t = Timer
	Cells.Clear
	Dim myXML As Object
	Set myXML = CreateObject("WinHttp.WinHttpRequest.5.1")
	Dim myHTML As Object
	Set myHTML = CreateObject("HTMLFile")
	With myXML
	.Open "GET", "http://isin.twse.com.tw/isin/class_main.jsp?market=1&issuetype=1&Page=1&chklike=Y", False
	.send
	myHTML.body.innerHTML = convertraw(.responsebody)
	Set myTable = myHTML.getElementsByTagName("table")(1)
	RowCount = myTable.Rows.Length
	colCount = myTable.Rows(1).Cells.Length
	ReDim myArr1(1 To RowCount, 1 To colCount)
	For i = 0 To RowCount - 1
	For j = 2 To colCount - 1
	myArr1(i + 1, j - 1) = myTable.Rows(i).Cells(j).innerText
	Next
	Next
	lastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
	.Open "GET", "http://isin.twse.com.tw/isin/class_main.jsp?market=2&issuetype=4&Page=1&chklike=Y", False
	.send
	myHTML.body.innerHTML = convertraw(.responsebody)
	Set myTable = myHTML.getElementsByTagName("table")(1)
	RowCount = myTable.Rows.Length
	colCount = myTable.Rows(1).Cells.Length
	ReDim myArr2(1 To RowCount, 1 To colCount)
	For i = 1 To RowCount - 1
	For j = 2 To colCount - 1
	myArr2(i, j - 1) = myTable.Rows(i).Cells(j).innerText
	Next
	Next
	Range("A1").Resize(UBound(myArr1, 1), UBound(myArr1, 2)).Value = myArr1
	lastRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
	Cells(lastRow, "A").Resize(UBound(myArr2, 1), UBound(myArr2, 2)).Value = myArr2
	End With
	Set myXML = Nothing
	Erase myArr1
	Erase myArr2
	Application.StatusBar = "下載完畢，共花" & Format(Timer - t, "0.00秒")
	End Sub

view raw main hosted with ❤ by GitHub

以及轉碼程式:

	Function convertraw(rawdata)
	Dim rawstr
	Set rawstr = CreateObject("adodb.stream")
	With rawstr
	.Type = 1
	.Mode = 3
	.Open
	.Write rawdata
	.Position = 0
	.Type = 2
	.Charset = "big5"
	convertraw = .ReadText
	.Close
	End With
	Set rawstr = Nothing
	End Function

view raw convert hosted with ❤ by GitHub