Zellen nicht mehr löschbar nach Prozdeur

Sub Pivot() Range("A1:Z1").Font.Bold = True Range("A1:C10000").Select ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ "StocksInformation!A1:C10000", Version:=6).CreatePivotTable _ TableDestination:="StocksInformation!R1C8", TableName:="PivotTable6", _ DefaultVersion:=6 Sheets("StocksInformation").Select Cells(1, 8).Select With ActiveSheet.PivotTables("PivotTable6").PivotFields("Date") .Orientation = xlRowField .Position = 1 End With ActiveSheet.PivotTables("PivotTable6").PivotFields("Date").AutoGroup ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _ "PivotTable6").PivotFields("High"), "Anzahl von High", xlCount ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _ "PivotTable6").PivotFields("Low"), "Anzahl von Low", xlCount With ActiveSheet.PivotTables("PivotTable6").PivotFields("Anzahl von High") .Caption = "Maximum von High" .Function = xlMax End With With ActiveSheet.PivotTables("PivotTable6").PivotFields("Anzahl von Low") .Caption = "Minimum von Low" .Function = xlMin End With ActiveSheet.PivotTables("PivotTable6").RowGrand = False Columns("H:J").Select Selection.Copy Columns("K:K").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("H:J").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Range("H1").Select ActiveCell.FormulaR1C1 = "Jahr" Range("I1").Select ActiveCell.FormulaR1C1 = "High" Range("J1").Select ActiveCell.FormulaR1C1 = "Low" Range("H1").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Selection.Font.Bold = True Range("I1:J1").Select Selection.Font.Bold = True Range("I2:J2").Select Range(Selection, Selection.End(xlDown)).Select Range(Selection, Selection.End(xlDown)).Select Selection.NumberFormat = "0.00" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

Zellen nicht mehr löschbar nach Prozdeur

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

133 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen nicht mehr löschbar nach Prozdeur

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

133 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread