Schleife in Makro einbauen
04.01.2019 20:29:59
Christian
wollte mal fragen, ob jemand der sich mit Makros auskennt, da etwas einbaut, was die Abfrage bei Bedarf wiederholt:
Ich versuche ganz kurz zu sagen, was ich möchte, ohne dass zu viele Erklärungen zu viele Fragen und Misverständnisse aufwerfen:
Das Makro geht hin, arbeitet eine Liste von Internetseiten ab und kopiert gewisse Daten in meine Tabelle. Mein Wunsch ist dass sobald bei einem Link nichts eingefügt wurde, es so lange wiederholt wird, bis etwas eingefügt wurde und erst dann zum nächsten Link übergegangen wird. Ist das machbar?
Das Makro gibt in dem Fall das nichts heruntergeladen wird keinen Fehler aus.
Option Explicit
Public Sub Main()
Dim objIEApp As Object
Dim objIEDoc As Object
Dim objTab As Object
Dim lngCount As Long
Dim lngCalc As Long
Dim lngTMP As Long
Dim lngRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
With Tabelle2
lngCount = IIf(Len(.Cells(.Rows.Count, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
With ThisWorkbook.Worksheets("Tabelle1")
Set objIEApp = CreateObject("InternetExplorer.Application")
objIEApp.Visible = False
For lngCount = 1 To lngCount
objIEApp.Navigate Tabelle2.Cells(lngCount, 1).Text
Do: Loop Until objIEApp.Busy = False
Do: Loop Until objIEApp.Busy = False
Set objIEDoc = objIEApp.Document
Do: Loop Until objIEDoc.ReadyState 4
lngRow = IIf(Len(.Cells(.Rows.Count, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
For Each objTab In objIEApp.Document.all
If objTab.className = "this-week" And objTab.nodeName = "SPAN" Then
Tabelle1.Cells(lngRow, 1) = CLng(objTab.innerText)
ElseIf objTab.className = "info-title" And objTab.nodeName = "SPAN" Then
Tabelle1.Cells(lngRow, 2) = objTab.innerText
lngRow = lngRow + 1
ElseIf objTab.className = "info-artist" And objTab.nodeName = "SPAN" Then
Tabelle1.Cells(lngRow, 3) = objTab.innerText
End If
Next objTab
Next lngCount
.Range("A1").Value = "Platz"
.Range("B1").Value = "Titel"
.Range("C1").Value = "Interpret"
.Columns("A:C").AutoFit
End With
Fin:
objIEApp.Quit
Set objIEDoc = Nothing
Set objIEApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub