AW: Externe Abfrage filtern und sortieren
11.07.2017 09:30:21
fcs
Hallo JonnyBank,
hier eine Variante
Die Inhalte in den unerwünschten Import-Zeilen werden gelöscht, dann der Zellbereich nach dem Datum sortiert. Laufzeit der Aufbereitung ca. 3 bis 5 Sekunden.
Gruß
Franz
Sub Kurs1()
'Deklaration der Variablen für den URL
Dim ticker, crumb
Dim period1, period2 As Long
' Nun sagen wir dem Programm wo sich die Variablen befinden
'Aktie:
ticker = Range("AktieSymbol1")
'Datum
period1 = Range("period1")
period2 = Range("period2")
crumb = Range("crum")
Range("B31:C15000").Select
Selection.ClearContents
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;https://query1.finance.yahoo.com/v7/finance/download/" & ticker & "?period1=" & _
period1 & "&period2=" & period2 & "&interval=1d&events=history&crumb=" & crumb & "" _
, Destination:=Range("$B$31"))
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
' aus 1 eine 9 machen um auszublenden
.TextFileColumnDataTypes = Array(1, 9, 9, 9, 9, 1, 9)
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = " "
.Refresh BackgroundQuery:=False
Call prcCleanUp(Range("B31:C15000")) 'neue Zeile
'Kommastellen und Autofit
Columns("B:C").EntireColumn.AutoFit
Columns("B:B").Select
Selection.NumberFormat = "m/d/yyyy"
Range("C31:C15000").Select
Selection.Style = "Comma"
End With
End Sub
Public Sub prcCleanUp(rngBereich As Range)
Dim Zeile As Long
Dim StatusCalc As Long
'löscht Zeilen mit Wert 0 in 2. Spalte oder wenn Zelltext = ""
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With rngBereich
For Zeile = 1 To rngBereich.Rows.Count
If .Cells(Zeile, 2).Value = 0 Then
.Rows(Zeile).ClearContents
ElseIf .Cells(Zeile, 1).Text = "" Or .Cells(Zeile, 2).Text = "" Then
.Rows(Zeile).ClearContents
End If
Next
.Sort key1:=.Range("A1"), Order1:=xlAscending, Header:=xlNo
End With
With Application
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End Sub