AW: Zellen nicht mehr löschbar nach Prozdeur
24.02.2023 01:08:19
Marc
Sorry, ich hatte Deine Frage falsch verstanden.
Der Code liegt in einem Modul und wird aus der folgenden Sub aufgerufen:
Sub getYahoo()
' Kurse abrufen
Dim aSheet As Worksheet
Dim UnixStart As Long
Dim UnixEnd As Long
Dim Diff As Long
Dim Ticker As String
Dim stocksinfo As Worksheet
Dim lastrow As Long
Dim row As Long
Dim Tag As Variant
Dim Monat As Variant
Dim Datum As Date
Dim Hilfsdatum As Date
Dim Projektname As String
Projektname = ThisWorkbook.Name
Dim QT As QueryTable
Set aSheet = Workbooks(Projektname).Worksheets("Prozessbeschreibung")
Set stocksinfo = Workbooks(Projektname).Worksheets("Stocksinformation")
Ticker = aSheet.Range("J15").Value
' Periode (Startdatum & Enddatum) ermitteln und Unix Datum ermitteln für "Kursdaten" !
FiscalDate = CDate(aSheet.Range("J17").Value)
Diff = DateDiff("yyyy", "1.1.2000", aSheet.Range("J17").Value) * (-1)
Enddatum = CDate(FiscalDate)
UnixEnd = DateDiff("d", "1.1.1970", Enddatum) * 86400
Startdatum = DateAdd("yyyy", Diff, Enddatum)
Startdatum = DateAdd("d", 1, Startdatum)
UnixStart = DateDiff("d", "1.1.1970", Startdatum) * 86400
'Kurse abrufen
With stocksinfo
.Activate
.Range("A1:Z20000").ClearContents
.Range("A1:Z20000").ClearFormats
End With
Set QT = stocksinfo.QueryTables.Add(Connection:="TEXT;https://query1.finance.yahoo.com/v7/finance/download/" & Ticker & "?period1=" & UnixStart & "&period2=" & UnixEnd & "&interval=1d&events=history", Destination:=Range("$A$1"))
With QT
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(4, 1, 1, 1, 1, 1, 1)
.TextFileThousandsSeparator = " "
.TextFileDecimalSeparator = "."
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
' Warteschleife
Dim Countdown As Single, i As Long
Countdown = Timer + 5
Do While Timer = Countdown
i = i + 1
Loop
'--------Überflüssige Kursspalten löschen----------
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("D:F").Select
Selection.Delete Shift:=xlToLeft
Range("B2:C2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("B1:C1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'--------------------------------------------------
Set QT = Nothing ' Querytable Object zurücksetzen
' Aktiensplits abrufen
Set QT = stocksinfo.QueryTables.Add(Connection:="TEXT;https://query1.finance.yahoo.com/v7/finance/download/" & Ticker & "?period1=" & UnixStart & "&period2=" & UnixEnd & "&interval=1d&events=split&includeAdjustedClose=true", Destination:=Range("$E$2"))
With QT
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(4, 1)
.TextFileThousandsSeparator = False
.TextFileDecimalSeparator = "."
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
' Warteschleife
Countdown = Timer + 2
Do While Timer = Countdown
i = i + 1
Loop
Set QT = Nothing ' Querytable Object zurücksetzen
' Alle Verbindungen wieder löschen.
For Each QT In stocksinfo.QueryTables
QT.Delete
Next
' Splits absteigend sortieren nach Datum
Range("D1").Value = "Abweichendes FJ"
Range("E1").Value = "Yahoo-Splits"
Range("F1").Value = "Ratio"
Columns("E:F").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("StocksInformation").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("StocksInformation").AutoFilter.Sort.SortFields.Add _
Key:=Range("E1:E10000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("StocksInformation").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("D:F").EntireColumn.AutoFit
Selection.AutoFilter
' Wenn Fiskaljahr und Kalenderjahr identisch sind dann Aufruf von Pivot
If Day(Enddatum) = 31 And Month(Enddatum) = 12 Then
Call Pivot
Countdown = Timer + 2
Do While Timer = Countdown
i = i + 1
Loop
Else
' Ansonsten zunächst das Fiskaljahr deklarieren und anschließend PivotAbweichend aufrufen
lastrow = stocksinfo.Cells(Rows.Count, 1).End(xlUp).row
For row = 2 To lastrow
Datum = CDate(stocksinfo.Cells(row, 1).Value)
Hilfsdatum = CDate(Day(FiscalDate) & "." & Month(FiscalDate) & "." & year(stocksinfo.Cells(row, 1).Value))
If Datum = Hilfsdatum Then
stocksinfo.Cells(row, 4).Value = year(stocksinfo.Cells(row, 1).Value) - 1
Else
stocksinfo.Cells(row, 4).Value = year(stocksinfo.Cells(row, 1).Value)
End If
Next row
Call PivotAbweichend
End If
' Warten bis Aufgabe erledigt wurde
Countdown = Timer + 2
Do While Timer = Countdown
i = i + 1
Loop
' Letzte überflüssige Zeile der Pivot entfernen ("Gesamtergebnis")
lastrow = stocksinfo.Cells(Rows.Count, 8).End(xlUp).row
stocksinfo.Range(stocksinfo.Cells(lastrow, 8), stocksinfo.Cells(lastrow, 10)).Clear
' Events ziehen
Call getEvents
' XML High/Low ziehen
Call xmlQuotes
' BasicSharesOut ziehen
Call getshares
' Stocknews ziehen
Call getStocknews
' DividendPayment ziehen
Call getDividendPayment
End Sub