用於網頁掃描的宏功能

Question

如何爲excel創建一個宏，以便從網站上刮取某些數據並將這些數據實施到數據庫中，並將該宏數據庫用於同一數據庫中的許多網站？例如，我想從https://finance.yahoo.com/quote/CSCO?p=CSCO和https://finance.yahoo.com/quote/BBRY/

拉開啓和關閉的價格謝謝

Answer 1

試試這個。

'Samir Khan 
'simulationconsultant@gmail.com 
'The latest version of this spreadsheet can be downloaded from http://investexcel.net/multiple-stock-quote-downloader-for-excel/ 
'Please link to http://investexcel.net if you like this spreadsheet 


Sub DownloadStockQuotes(ByVal stockTicker As String, ByVal StartDate As Date, ByVal EndDate As Date, ByVal DestinationCell As String, ByVal freq As String) 

Dim qurl As String 
Dim StartMonth, StartDay, StartYear, EndMonth, EndDay, EndYear As String 

qurl = "http://finance.google.com/finance/historical?q=" & stockTicker 
qurl = qurl & "&startdate=" & MonthName(Month(StartDate), True) & _ 
     "+" & Day(StartDate) & "+" & Year(StartDate) & _ 
     "&enddate=" & MonthName(Month(EndDate), True) & _ 
     "+" & Day(EndDate) & "+" & Year(EndDate) & "&output=csv" 

On Error GoTo ErrorHandler: 

QueryQuote: 
With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=Range(DestinationCell)) 
    .BackgroundQuery = True 
    .TablesOnlyFromHTML = False 
    .Refresh BackgroundQuery:=False 
    .SaveData = True 
End With 

ErrorHandler: 

End Sub 

Sub DownloadData() 

Dim frequency As String 
Dim numRows As Integer 
Dim lastRow As Integer 
Dim lastErrorRow As Integer 
Dim lastSuccessRow As Integer 
Dim stockTicker As String 
Dim numStockErrors As Integer 
Dim numStockSuccess As Integer 

numStockErrors = 0 
numStockSuccess = 0 

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 

lastErrorRow = ActiveSheet.Cells(Rows.Count, "J").End(xlUp).Row 
lastSuccessRow = ActiveSheet.Cells(Rows.Count, "L").End(xlUp).Row 

ClearErrorList lastErrorRow 
ClearSuccessList lastSuccessRow 

lastRow = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row 
frequency = Worksheets("Parameters").Range("b7") 

'Delete all sheets apart from Parameters sheet 
Dim ws As Worksheet 
Application.DisplayAlerts = False 
For Each ws In Worksheets 
    If ws.Name <> "Parameters" And ws.Name <> "About" Then ws.Delete 
Next 

Application.DisplayAlerts = True 

'Loop through all tickers 
For ticker = 12 To lastRow 

    stockTicker = Worksheets("Parameters").Range("$a$" & ticker) 

    If stockTicker = "" Then 
     GoTo NextIteration 
    End If 

    Sheets.Add After:=Sheets(Sheets.Count) 

    If InStr(stockTicker, ":") > 0 Then 
     ActiveSheet.Name = Replace(stockTicker, ":", "") 
    Else 
     ActiveSheet.Name = stockTicker 
    End If 

    Cells(1, 1) = "Stock Quotes for " & stockTicker 
    Call DownloadStockQuotes(stockTicker, Worksheets("Parameters").Range("$b$5"), Worksheets("Parameters").Range("$b$6"), "$a$2", frequency) 
    Columns("a:a").TextToColumns Destination:=Range("a1"), DataType:=xlDelimited, _ 
           TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ 
           Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1)) 


    If InStr(stockTicker, ":") > 0 Then 
     stockTicker = Replace(stockTicker, ":", "") 
    End If 

    Sheets(stockTicker).Columns("A:G").ColumnWidth = 10 

    lastRow = Sheets(stockTicker).UsedRange.Row - 2 + Sheets(stockTicker).UsedRange.Rows.Count 

    If lastRow < 3 Then 
     Application.DisplayAlerts = False 
     Sheets(stockTicker).Delete 
     numStockErrors = numStockErrors + 1 
     ErrorList stockTicker, numStockErrors 
     GoTo NextIteration 
     Application.DisplayAlerts = True 
    Else 
     numStockSuccess = numStockSuccess + 1 
     If Left(stockTicker, 1) = "^" Then 
      SuccessList Replace(stockTicker, "^", ""), numStockSuccess 
     Else 
      SuccessList stockTicker, numStockSuccess 
     End If 
    End If 

    Sheets(stockTicker).Sort.SortFields.Add Key:=Range("A3:A" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
    With Sheets(stockTicker).Sort 
     .SetRange Range("A2:G" & lastRow) 
     .Header = xlYes 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .SortMethod = xlPinYin 
     .Apply 
    End With 

    Range("a3:a" & lastRow).NumberFormat = "yyyy-mm-dd;@" 

    'Delete final blank row otherwise will get ,,,, at bottom of CSV 
    Sheets(stockTicker).Rows(lastRow + 1 & ":" & Sheets(stockTicker).Rows.Count).Delete 

    'Remove initial^in ticker names from Sheets 
    If Left(stockTicker, 1) = "^" Then 
     ActiveSheet.Name = Replace(stockTicker, "^", "") 
    Else 
     ActiveSheet.Name = stockTicker 
    End If 

    'Remove hyphens in ticker names from Sheet names, otherwise error in collation 
    If InStr(stockTicker, "-") > 0 Then 
     ActiveSheet.Name = Replace(stockTicker, "-", "") 
    End If 


NextIteration: 
Next ticker 

Application.DisplayAlerts = False 

If Sheets("Parameters").Shapes("WriteToCSVCheckBox").ControlFormat.Value = xlOn Then 
    On Error GoTo ErrorHandler: 
    Call CopyToCSV 
End If 

If Sheets("Parameters").Shapes("CollateDataCheckBox").ControlFormat.Value = xlOn Then 
    On Error GoTo ErrorHandler: 
    Call CollateData 
End If 

ErrorHandler: 

Worksheets("Parameters").Select 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

Worksheets("Parameters").Select 
For Each C In ThisWorkbook.Connections 
    C.Delete 
Next 

End Sub 
Sub CollateData() 

Dim ws As Worksheet 
Dim i As Integer, first As Integer 
Dim maxRow As Integer 
Dim maxTickerWS As Worksheet 

maxRow = 0 
For Each ws In Worksheets 
    If ws.Name <> "Parameters" Then 
     If ws.UsedRange.Rows.Count > maxRow Then 
      maxRow = ws.UsedRange.Rows.Count 
      Set maxTickerWS = ws 
     End If 
    End If 
Next 

Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Name = "Open" 

Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Name = "High" 

Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Name = "Low" 

Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Name = "Close" 

Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Name = "Volume" 

Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Name = "Adjusted Close" 

i = 1 
maxTickerWS.Range("A2", "B" & maxRow).Copy Destination:=Sheets("Open").Cells(1, i) 
Sheets("Open").Cells(1, i + 1) = maxTickerWS.Name 

maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("High").Cells(1, i) 
maxTickerWS.Range("c2", "c" & maxRow).Copy Destination:=Sheets("High").Cells(1, i + 1) 
Sheets("High").Cells(1, i + 1) = maxTickerWS.Name 

maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Low").Cells(1, i) 
maxTickerWS.Range("d2", "d" & maxRow).Copy Destination:=Sheets("Low").Cells(1, i + 1) 
Sheets("Low").Cells(1, i + 1) = maxTickerWS.Name 

maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Close").Cells(1, i) 
maxTickerWS.Range("e2", "e" & maxRow).Copy Destination:=Sheets("Close").Cells(1, i + 1) 
Sheets("Close").Cells(1, i + 1) = maxTickerWS.Name 

maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Volume").Cells(1, i) 
maxTickerWS.Range("f2", "f" & maxRow).Copy Destination:=Sheets("Volume").Cells(1, i + 1) 
Sheets("Volume").Cells(1, i + 1) = maxTickerWS.Name 

maxTickerWS.Range("A2", "a" & maxRow).Copy Destination:=Sheets("Adjusted Close").Cells(1, i) 
maxTickerWS.Range("g2", "g" & maxRow).Copy Destination:=Sheets("Adjusted Close").Cells(1, i + 1) 
Sheets("Adjusted Close").Cells(1, i + 1) = maxTickerWS.Name 

i = i + 2 

For Each ws In Worksheets 

    If ws.Name <> "Parameters" And ws.Name <> "About" And ws.Name <> maxTickerWS.Name And ws.Name <> "Open" And ws.Name <> "High" And ws.Name <> "Low" And ws.Name <> "Close" And ws.Name <> "Volume" And ws.Name <> "Adjusted Close" Then 

     Sheets("Open").Cells(1, i) = ws.Name 
     Sheets("Open").Range(Sheets("Open").Cells(2, i), Sheets("Open").Cells(maxRow - 1, i)).Formula = _ 
     "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",2,0)" 

     Sheets("High").Cells(1, i) = ws.Name 
     Sheets("High").Range(Sheets("High").Cells(2, i), Sheets("High").Cells(maxRow - 1, i)).Formula = _ 
     "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",3,0)" 

     Sheets("Low").Cells(1, i) = ws.Name 
     Sheets("Low").Range(Sheets("Low").Cells(2, i), Sheets("Low").Cells(maxRow - 1, i)).Formula = _ 
     "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",4,0)" 

     Sheets("Close").Cells(1, i) = ws.Name 
     Sheets("Close").Range(Sheets("Close").Cells(2, i), Sheets("Close").Cells(maxRow - 1, i)).Formula = _ 
     "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",5,0)" 

     Sheets("Volume").Cells(1, i) = ws.Name 
     Sheets("Volume").Range(Sheets("Volume").Cells(2, i), Sheets("Volume").Cells(maxRow - 1, i)).Formula = _ 
     "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",6,0)" 

     Sheets("Adjusted Close").Cells(1, i) = ws.Name 
     Sheets("Adjusted Close").Range(Sheets("Adjusted Close").Cells(2, i), Sheets("Adjusted Close").Cells(maxRow - 1, i)).Formula = _ 
     "=vlookup(A2," & ws.Name & "!A$2:G$" & maxRow & ",7,0)" 

     i = i + 1 

    End If 
Next 

On Error Resume Next 

Sheets("Open").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear 
Sheets("Close").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear 
Sheets("High").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear 
Sheets("Low").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear 
Sheets("Volume").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear 
Sheets("Adjusted Close").UsedRange.SpecialCells(xlFormulas, xlErrors).Clear 

On Error GoTo 0 

Sheets("Open").Columns("A:A").EntireColumn.AutoFit 
Sheets("High").Columns("A:A").EntireColumn.AutoFit 
Sheets("Low").Columns("A:A").EntireColumn.AutoFit 
Sheets("Close").Columns("A:A").EntireColumn.AutoFit 
Sheets("Volume").Columns("A:A").EntireColumn.AutoFit 
Sheets("Adjusted Close").Columns("A:A").EntireColumn.AutoFit 
End Sub 

Sub SuccessList(ByVal stockTicker As String, ByVal numStockSuccess As Integer) 

Sheets("Parameters").Range("L" & 10 + numStockSuccess) = stockTicker 

Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlDiagonalDown).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlDiagonalUp).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeLeft).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeTop).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeBottom).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeRight).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlInsideVertical).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlInsideHorizontal).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlDiagonalDown).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlDiagonalUp).LineStyle = xlNone 

With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeLeft) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlMedium 
End With 
With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeTop) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlMedium 
End With 
With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeBottom) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlMedium 
End With 
With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlEdgeRight) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlMedium 
End With 

Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlInsideVertical).LineStyle = xlNone 
Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Borders(xlInsideHorizontal).LineStyle = xlNone 

With Sheets("Parameters").Range("L10:L" & 10 + numStockSuccess).Interior 
    .PatternColorIndex = xlAutomatic 
    .ThemeColor = xlThemeColorAccent2 
    .TintAndShade = 0.799981688894314 
    .PatternTintAndShade = 0 
End With 

End Sub 

Sub ErrorList(ByVal stockTicker As String, ByVal numStockErrors As Integer) 

Sheets("Parameters").Range("J" & 10 + numStockErrors) = stockTicker 

Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlDiagonalDown).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlDiagonalUp).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeLeft).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeTop).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeBottom).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeRight).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlInsideVertical).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlInsideHorizontal).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlDiagonalDown).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlDiagonalUp).LineStyle = xlNone 

With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeLeft) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlMedium 
End With 
With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeTop) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlMedium 
End With 
With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeBottom) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlMedium 
End With 
With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlEdgeRight) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlMedium 
End With 

Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlInsideVertical).LineStyle = xlNone 
Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Borders(xlInsideHorizontal).LineStyle = xlNone 

With Sheets("Parameters").Range("J10:J" & 10 + numStockErrors).Interior 
    .PatternColorIndex = xlAutomatic 
    .ThemeColor = xlThemeColorAccent2 
    .TintAndShade = 0.799981688894314 
    .PatternTintAndShade = 0 
End With 

End Sub 

Sub ClearErrorList(ByVal lastErrorRow As Integer) 
If lastErrorRow > 10 Then 
    Worksheets("Parameters").Range("J11:J" & lastErrorRow).Clear 
    With Sheets("Parameters").Range("J10").Borders(xlEdgeLeft) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
    With Sheets("Parameters").Range("J10").Borders(xlEdgeTop) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
    With Sheets("Parameters").Range("J10").Borders(xlEdgeBottom) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
    With Sheets("Parameters").Range("J10").Borders(xlEdgeRight) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
End If 
End Sub 

Sub ClearSuccessList(ByVal lastSuccessRow As Integer) 
If lastSuccessRow > 10 Then 
    Worksheets("Parameters").Range("L11:L" & lastSuccessRow).Clear 
    With Sheets("Parameters").Range("L10").Borders(xlEdgeLeft) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
    With Sheets("Parameters").Range("L10").Borders(xlEdgeTop) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
    With Sheets("Parameters").Range("L10").Borders(xlEdgeBottom) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
    With Sheets("Parameters").Range("L10").Borders(xlEdgeRight) 
     .LineStyle = xlContinuous 
     .ColorIndex = 0 
     .TintAndShade = 0 
     .Weight = xlMedium 
    End With 
End If 
End Sub 


Sub CopyToCSV() 

Dim MyPath As String 
Dim MyFileName As String 

dateFrom = Worksheets("Parameters").Range("$b$5") 
dateTo = Worksheets("Parameters").Range("$b$6") 
frequency = Worksheets("Parameters").Range("$b$7") 
MyPath = Worksheets("Parameters").Range("$b$8") 

For Each ws In Worksheets 
    If ws.Name <> "Parameters" And ws.Name <> "About" Then 
     ticker = ws.Name 
     MyFileName = ticker & " " & Format(dateFrom, "dd-mm-yyyy") & " - " & Format(dateTo, "dd-mm-yyyy") & " " & frequency 
     If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\" 
     If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv" 
     Sheets(ticker).Copy 
     With ActiveWorkbook 
      .SaveAs Filename:= _ 
        MyPath & MyFileName, _ 
        FileFormat:=xlCSV, _ 
        CreateBackup:=False 
      .Close False 
     End With 
    End If 
Next 

End Sub 

http://investexcel.net/multiple-stock-quote-downloader-for-excel/