Daten ziehen funktioniert nicht mehr

Sub alledatenkurz()
' Dieses Makro dient dazu alle Daten aus den börse.de daten auszulesen und in  _
20200327_Aktienautomatik in die ISin Liste zu schreiben--------------------------------'
Workbooks("20200327_Aktienautomatik").Activate
Sheets("ISIN_Liste").Activate
Dim aktie As String
Dim zelleindex As Range
Dim bereichindex As Range
Dim letztezeile As Integer
Dim ws As Worksheet
Dim i As Integer
Dim letztezeileVA As Integer
Dim isin As String
Dim letztezeilezus As Integer
Dim aktieunterstrich As String
Dim zelle1 As Range
Dim bereich1 As Range
Dim n As Integer
Dim letztespalte As Integer
Dim letztespaltezus As Integer
Dim zähler As Integer
Dim beschriftung As Boolean
Dim speicher As Integer
Dim letztezeileisin As Integer
Dim aktuellesjahr As Integer
Dim letztesjahr As Integer
aktuellesjahr = Year(Date)
letztesjahr = aktuellesjahr - 1
zähler = 1
speicher = 0
Application.ScreenUpdating = True 'Bildschirmaktualisierung ausschalten
letztezeile = Worksheets("ISIN_Liste").Cells(Rows.Count, 1).End(xlUp).Row
Application.DisplayAlerts = False
'Alle Blätter löschen, die nicht zu den Stammblättern gehören ---------------------------------- _
For Each ws In ThisWorkbook.Worksheets
If ws.Name  "ISIN_Liste" Then
ws.Delete
End If
Next ws
Worksheets("ISIN_Liste").Activate
letztezeile = ActiveSheet.UsedRange.Rows.Count
letztespalte = ActiveSheet.UsedRange.Columns.Count
'Range(Cells(1, 6), Cells(letztezeile, letztespalte)).Clear
Set bereichindex = Worksheets("ISIN_Liste").Range(Cells(77, 1), Cells(letztezeile, 1))
'Abfrage starten für jede Zeile aus Spalte A und die Werte ab Zelle F eintragen ---------------- _
beschriftung = True
For Each zelle In bereichindex
aktie = zelle.Offset(0, 3).Value
isin = zelle.Offset(0, 2).Value
aktieunterstrich = zelle.Offset(0, 4).Value
Debug.Print aktie
Debug.Print isin
Debug.Print aktie & isin
Workbooks.Add
'Speichern des WB in Temp mit Überprüfung ------------------------------------------------------ _
ChDir "C:\Temp"
If Dir("C:\Temp\ISIN_DATEN.xlsx")  "" Then
Kill "C:\Temp\ISIN_DATEN.xlsx"
ActiveWorkbook.SaveAs Filename:="C:\Temp\ISIN_DATEN.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
Else
ActiveWorkbook.SaveAs Filename:="C:\Temp\ISIN_DATEN.xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
End If
Sheets("Tabelle1").Activate
Cells(1, 1).Select
'Alle Daten abrufen ---------------------------------------------------------------------------- _
On Error Resume Next
Application.CutCopyMode = False
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;https://www.boerse.de/fundamental-analyse/" & aktie & "/" & isin & "", _
Destination:=Range("$A$1"))
'.CommandType = 0
'.Name = "Fundamentaldaten"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
ActiveSheet.Name = "Fundamentaldaten"
'Abfrage ob Tabellenblatt leer ist----------------------'
Sheets("Fundamentaldaten").Cells(1, 1).Select
i = 1
Do Until i = 10
If ActiveCell.Value = "" Then
i = i + 1
ActiveCell.Offset(1, 0).Select
Else
Exit Do
End If
Loop
If i = 10 Then
GoTo nächste
End If
'Das folgende Blatt beinhaltet nur die Anzahl an Aktien und die Marktkapitalisierung ------- _
Sheets.Add After:=ActiveSheet
Application.CutCopyMode = False
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;https://www.boerse.de/aktien/" & aktie & "/" & isin & "", Destination:= _
Range("$A$1"))
'.CommandType = 0
'.Name = "Marktkapitalisierung"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingRTF
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = True
.Refresh BackgroundQuery:=False
End With
ActiveSheet.Name = "Marktkapitalisierung"
'Abfrage ob Tabellenblatt leer ist----------------------'
Sheets("Marktkapitalisierung").Cells(1, 1).Select
i = 1
Do Until i = 10
If ActiveCell.Value = "" Then
i = i + 1
ActiveCell.Offset(1, 0).Select
Else
Exit Do
End If
Loop
If i = 10 Then
GoTo nächste
End If
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Zusammenfassung"
'Alle Werte aus dem Blatt Fundamentaldaten ziehen und in Zusammenfassung eintragen ------------- _
Sheets("Fundamentaldaten").Activate
letztezeileisin = ActiveSheet.UsedRange.Rows.Count
Dim aktuellerkurs As String
Dim posumsatz As Integer 'für position umsatzzelle
Dim nummer As Integer
Cells(1, 1).Select
posumsatz = 0
nummer = 0
Do Until nummer = letztezeileisin
If ActiveCell.Value  "aktueller Kurs:" Then
ActiveCell.Offset(1, 0).Select
Else
aktuellerkurs = ActiveCell.Offset(0, 1).Value
Exit Do
End If
Loop
If nummer = letztezeileisin Then
GoTo nächste
End If
Cells(1, 1).Select
nummer = 0
Do Until nummer = letztezeileisin
If ActiveCell.Value  "Umsatz" Then
posumsatz = posumsatz + 1
ActiveCell.Offset(1, 0).Select
Else
Exit Do
End If
Loop
If nummer = letztezeileisin Then
GoTo nächste
End If
posumsatz = posumsatz + 1
Debug.Print "posumsatz= " & posumsatz
'Jahreszahlen in Zusammenfassung eintragen ----------------------------------------------------- _
Cells(posumsatz - 1, 1).Value = "Jahreszahlen"
Cells(posumsatz - 1, 1).Select
Dim aj As Integer 'für Anzahl Jahreszahlen
aj = 0
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
aj = aj + 1
Loop
aj = aj - 1
If Cells(posumsatz - 1, 1 + aj).Value  letztesjahr Then
GoTo nächste
End If
Debug.Print "AJ= " & aj
Range(Cells(posumsatz - 1, 2), Cells(posumsatz - 1, aj + 1)).Select
Selection.Copy
Sheets("Zusammenfassung").Activate
Cells(1, 2).PasteSpecial Paste:=xlPasteAll
Cells(1, 1).Value = "Jahreszahlen"
'Umsatz in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Range(Cells(posumsatz, 1), Cells(posumsatz, aj + 1)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'Ebit in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Cells(posumsatz, 1).Select
nummer = 0
Do Until ActiveCell.Value = "Operatives Ergebnis (EBIT)"
ActiveCell.Offset(1, 0).Select
nummer = nummer + 1
If nummer = 50 Then
GoTo nächste
End If
Loop
Range(ActiveCell, ActiveCell.Offset(0, aj)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'Eigenkapital in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Cells(posumsatz, 1).Select
nummer = 0
Do Until ActiveCell.Value = "Eigenkapital"
ActiveCell.Offset(1, 0).Select
nummer = nummer + 1
If nummer = 50 Then
GoTo nächste
End If
Loop
Range(ActiveCell, ActiveCell.Offset(0, aj)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'Jahresüberschuss in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Cells(posumsatz, 1).Select
nummer = 0
Do Until ActiveCell.Value = "Jahresüberschuss"
ActiveCell.Offset(1, 0).Select
nummer = nummer + 1
If nummer = 50 Then
GoTo nächste
End If
Loop
Range(ActiveCell, ActiveCell.Offset(0, aj)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'Eigenkapitalquote in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Cells(posumsatz + 20, 1).Select
Do Until ActiveCell.Value = "Eigenkapitalquote"
ActiveCell.Offset(1, 0).Select
nummer = nummer + 1
If nummer = 50 Then
GoTo nächste
End If
Loop
Range(ActiveCell, ActiveCell.Offset(0, aj)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'Gesamtverbindlichkeiten in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Cells(posumsatz + 15, 1).Select
nummer = 0
Do Until ActiveCell.Value = "Gesamtverbindlichkeiten"
ActiveCell.Offset(1, 0).Select
nummer = nummer + 1
If nummer = 50 Then
GoTo nächste
End If
Loop
Range(ActiveCell, ActiveCell.Offset(0, aj)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'Gewinn je Aktie in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Cells(posumsatz + 25, 1).Select
nummer = 0
Do Until ActiveCell.Value = "Gewinn je Aktie (unverwässert)"
ActiveCell.Offset(1, 0).Select
nummer = nummer + 1
If nummer = 50 Then
GoTo nächste
End If
Loop
Range(ActiveCell, ActiveCell.Offset(0, aj)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'Eigenkapitalrendite in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Cells(posumsatz + 47, 1).Select
nummer = 0
Do Until ActiveCell.Value = "Eigenkapitalrendite"
ActiveCell.Offset(1, 0).Select
nummer = nummer + 1
If nummer = 50 Then
GoTo nächste
End If
Loop
Range(ActiveCell, ActiveCell.Offset(0, aj)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'KGVs in Zusammenfassung kopieren ------------------------------'
Sheets("Fundamentaldaten").Activate
Cells(posumsatz + 38, 1).Select
nummer = 0
Do Until ActiveCell.Value = "KGV (Kurs-Gewinn-Verhältnis)"
ActiveCell.Offset(1, 0).Select
nummer = nummer + 1
If nummer = 50 Then
GoTo nächste
End If
Loop
Range(ActiveCell, ActiveCell.Offset(0, aj)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 1, 1).PasteSpecial Paste:=xlPasteAll
'Marktkapitalisierung und Anzahlaktien in zus eintragen-------------'
Dim anzak As Integer 'anzahlaktien
anzak = 0
letztezeileisin = ActiveSheet.UsedRange.Rows.Count
Sheets("Marktkapitalisierung").Activate
Cells(1, 1).Select
Do Until nummer = letztezeileisin
If ActiveCell.Value  "Anzahl der Aktien" Then
anzak = anzak + 1
ActiveCell.Offset(1, 0).Select
Else
Exit Do
End If
Loop
If nummer = letztezeileisin Then
GoTo nächste
End If
anzak = anzak + 1
Debug.Print "anzak = " & anzak
Cells(anzak - 1, 1).Value = "Jahreszahlen"
aj = 0
Cells(anzak - 1, 1).Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
aj = aj + 1
Loop
aj = aj - 1
Debug.Print "AJ2 = " & aj
Range(Cells(anzak - 1, 1), Cells(anzak + 1, aj + 1)).Copy
Sheets("Zusammenfassung").Activate
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
Cells(letztezeilezus + 4, 1).PasteSpecial Paste:=xlPasteAll
letztespaltezus = ActiveSheet.UsedRange.Columns.Count
'Zeilen aus Spalte A transformieren und mit Überschriften verbinden -------------'
Rows(1).Insert shift:=xlUp
Rows(1).Insert shift:=xlUp
Set bereich1 = Range(Cells(4, 1), Cells(10 + 2, 1))
n = 1
i = 1
For Each zelle1 In bereich1
Do Until i = n * (letztespaltezus - 1) + 1
Cells(1, 1 + i).Value = zelle1.Value
i = i + 1
Loop
n = n + 1
Next zelle1
For i = 1 To 10 - 2
Range(Cells(3, 2), Cells(3, letztespaltezus)).Copy
Cells(2, 2 + i * (letztespaltezus - 1)).Select
Selection.PasteSpecial xlPasteValues
Next i
Range(Cells(3, 2), Cells(3, letztespaltezus)).Copy
Cells(2, 2).Select
Selection.PasteSpecial xlPasteValues
' Zahlenwerte transformieren ---------------------------------------------
Range(Cells(4, 2), Cells(4, letztespaltezus)).Copy
Cells(3, 2).Select
Selection.PasteSpecial xlPasteAll
Cells(4, 1).EntireRow.Delete
For i = 1 To 10 - 2
Range(Cells(4, 2), Cells(4, letztespaltezus)).Copy
Cells(3, 2 + i * (letztespaltezus - 1)).Select
Selection.PasteSpecial xlPasteAll
Cells(4, 1).EntireRow.Delete
Next i
letztespaltezus = ActiveSheet.UsedRange.Columns.Count
Set bereich1 = Range(Cells(2, 2), Cells(2, letztespaltezus))
For Each zelle1 In bereich1
zelle1.Value = zelle1.Offset(-1, 0).Value & " " & zelle1.Value
Next zelle1
Cells(1, 1).EntireRow.Delete
'Zeilen aus Spalte A transformieren und mit Überschriften verbinden -------------'
Set bereich1 = Range(Cells(7, 1), Cells(8, 1))
n = 1
i = 1
For Each zelle1 In bereich1
Do Until i = n * (aj - 1) + 2
Cells(5, i + 1).Value = zelle1.Value
i = i + 1
Loop
n = n + 1
Next zelle1
Cells(5, 1 + 2 * aj).Value = Cells(8, 1).Value
Range(Cells(6, 2), Cells(6, aj + 1)).Copy
Cells(4, 2 + (aj)).Select
Selection.PasteSpecial xlPasteValues
Range(Cells(6, 2), Cells(6, aj + 1)).Copy
Cells(4, 2).Select
Selection.PasteSpecial xlPasteValues
' Zahlenwerte transformieren ---------------------------------------------
Range(Cells(7, 2), Cells(7, aj + 1)).Copy
Cells(6, 2).Select
Selection.PasteSpecial xlPasteAll
Cells(7, 1).EntireRow.Delete
Range(Cells(7, 2), Cells(7, aj + 1)).Copy
Cells(6, aj + 2).Select
Selection.PasteSpecial xlPasteAll
Cells(7, 1).EntireRow.Delete
Set bereich1 = Range(Cells(4, 2), Cells(4, 2 * aj + 1))
For Each zelle1 In bereich1
zelle1.Value = zelle1.Offset(1, 0).Value & " " & zelle1.Value
Next zelle1
Cells(5, 1).EntireRow.Delete
letztespaltezus = ActiveSheet.UsedRange.Columns.Count
Range(Cells(4, 2), Cells(5, 2 * aj + 2)).Copy
Cells(1, letztespaltezus + 1).PasteSpecial Paste:=xlAll
letztespaltezus = ActiveSheet.UsedRange.Columns.Count
Cells(1, letztespaltezus + 1).Value = "Aktueller Kurs"
Cells(2, letztespaltezus + 1).Value = aktuellerkurs
'Werte aus Zusammenfassung eintragen ----------------------------------------------------------- _
letztezeilezus = ActiveSheet.UsedRange.Rows.Count
letztespaltezus = ActiveSheet.UsedRange.Columns.Count
If beschriftung = False Then
ActiveSheet.Range(Cells(1, 2), Cells(2, letztespaltezus)).Copy
Workbooks("20200327_Aktienautomatik").Sheets("ISIN_Liste").Activate
zelle.Offset(-1, 5).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False,  _
Transpose:=False
beschriftung = True
Else
ActiveSheet.Range(Cells(2, 2), Cells(2, letztespaltezus)).Copy
Workbooks("20200327_Aktienautomatik").Sheets("ISIN_Liste").Activate
zelle.Offset(0, 5).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False,  _
Transpose:=False
End If
'Neu erstelltes WB wieder schließen und löschen ------------------------------------------------ _
nächste:
Workbooks("ISIN_DATEN").Activate
Workbooks("ISIN_DATEN").Close savechanges:=False
Kill "C:\Temp\ISIN_DATEN.xlsx"
Application.DisplayStatusBar = True
zähler = zähler + 1
Application.StatusBar = "Es läuft Nr. " & zähler & " von " & letztezeile & " => " & 100 /  _
letztezeile * zähler & "%"
'Application.Wait (Now + TimeValue("0:00:5"))
'speicher = speicher + 1
'Debug.Print "Speicher = " & speicher
'If speicher = 30 Then
Workbooks("20200327_Aktienautomatik").Save
'    speicher = 0
'End If
Next zelle
Workbooks("20200327_Aktienautomatik").Save
'Formatierung zur besseren Lesbarkeit ---------------------------------------------------------- _
Workbooks("20200327_Aktienautomatik").Sheets("ISIN_Liste").Activate
ActiveSheet.UsedRange.Columns.AutoFit
letztezeile = ActiveSheet.UsedRange.Rows.Count
letztespalte = ActiveSheet.UsedRange.Columns.Count
Range(Cells(1, 1), Cells(1, letztespalte)).Font.Bold = True
Range(Cells(1, 1), Cells(1, letztespalte)).Interior.ColorIndex = 16
Set bereich = Range(Cells(2, 1), Cells(letztezeile, letztespalte))
For Each zelle In bereich
zelle.Interior.ColorIndex = 0
Next zelle
Set bereich = Range(Cells(2, 1), Cells(letztezeile, 1))
zähler = 1
For Each zelle In bereich
zähler = zähler + 1
Select Case zelle.Value
Case "TecDAX"
Range(Cells(zähler, 1), Cells(zähler, letztespalte)).Interior.ColorIndex = 33
Case "Mdax"
Range(Cells(zähler, 1), Cells(zähler, letztespalte)).Interior.ColorIndex = 33
Case "S&P500"
Range(Cells(zähler, 1), Cells(zähler, letztespalte)).Interior.ColorIndex = 33
Case "Eurostoxx"
Range(Cells(zähler, 1), Cells(zähler, letztespalte)).Interior.ColorIndex = 33
Case "ATX"
Range(Cells(zähler, 1), Cells(zähler, letztespalte)).Interior.ColorIndex = 33
Case "Nikkei 225"
Range(Cells(zähler, 1), Cells(zähler, letztespalte)).Interior.ColorIndex = 33
End Select
Next zelle
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Cells(1, letztespalte + 1).Value = "Ende"
Cells(1, letztespalte + 1).Interior.ColorIndex = 3
'Call aktuelledatenziehenkurz
End Sub