VBA Status Balken

[Florian20]

Hallo und Guten Morgen,

Ich habe zu dem Thema VBA Internet suche was übrigens sehr gut gelöst worden ist :18:  nun eine zusätzliche Frage.
Ich möchte gerne einen Status Balken anzeigen, während das Makro sucht.
Habe auch schon im Internet da nach gesucht, aber nichts passendes gefunden, weil Ich ein Makro mit schleife habe.

Hier mal die Idee aus dem Internet leicht abgewandelt:


Option Explicit

Public SW As Long
Public Schritt As Double
Public Länge1 As Double
Public Länge2 As Double

Public Sub Progressbar1()
Dim i As Long
Dim Länge As Double

Länge = (Länge1 & Länge2)
  SW = 2500                                       'Schrittweite festlegen
  Länge = 0
  Schritt = UserForm1.Label1.Width / SW                 'Schrittbreite pro Aktualisierung

For i = 2 To SW
    UserForm1.Label2.Width = Länge
    UserForm1.Label2.BackColor = RGB(0, 0, 255)
    UserForm1.Label3.Caption = Format(i / SW, "0 %")
    DoEvents
Next
End Sub

hoffe Ihr schlauen Leute könnt mir wieder helfen.
Lg
Flo

[Klaus-Dieter]

Hallo,

Status-Balken ist Murks. Optimiere das Makro dahingehend, dass es schnell genug läuft, dann kannst du auf solchen Schnickschnack verzichten.

[RPP63]

@Klaus-Dieter:
Es geht hier um eine Datei, die mittels Schleife mehrere Internetabfragen durchführt.
Selbst bei meinem 50MBit-Internetanschluss würde eine Statusbar in diesem Fall sehr wohl Sinn machen, denn das Neuzeichnen ist dort sicherlich nicht zeitkritisch!

Gruß Ralf

[Phi.VBA]

@Florian,

ohne über den Sinn diskutieren zu wollen, ein recht einfacher Ansatz ist:

Code:

Sub Status_Anzeige()
for i = 1 to 100
    'ein langsamer Code
    application.statusbar = i
next i
end sub

[Florian20]

Hallo nochmal.

Also das habe ich schon getestet aber da ich eine Schleife in dem Code habe geht das nicht   oder Ich weiß nicht wie.
Aber Ich habe eine UserForm mit der Ich die Abfrage starte, kann man dort nicht so etwas anzeigen?

[Steffl]

Hallo Florian,

poste doch deinen Code mit VBA InternetSuche

[Florian20]

OK aber der Code ist sehr Groß.

Sub xmlHTML()
Application.ScreenUpdating = False
'Prüft alle Firmen in Google!!
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
Dim i As Integer, str_text As String
Const strVorNr As String = "

"
Const strNachNr As String = ""
'=================================================================================================================================
'letzte benutzte Zelle in Spalte H finden
With ActiveSheet
  i = .Cells(Rows.Count, 8).End(xlUp).Row
End With
  lastRow = Range("A" & Rows.Count).End(xlUp).Row
  GoogleSuche.Label1.Width = 0
For i = i + 1 To lastRow
If lastRow = ("STEFFEN SCHULZ") Or ("GERALD BÖHM") Or ("HANS TRAUTMANN") Or ("WALTER SCHIMMEL") Then
  Resume Next
    End If
   
FZahl1 = FZahl1 + 1
GoogleSuche.Label1.BackColor = RGB(0, 255, 0)
GoogleSuche.Label1.Width = FZahl1
GoogleSuche.Label3.Caption = FZahl1 & "%"
    url = "https://www.google.co.in/search?q=" & URLEncode(Cells(i, 1) & Cells(i, 3) & " Telefonnummer")
    Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
      XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
       XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
    XMLHTTP.send
'=================================================================================================================================
'Überprüft alle Neuen Firmen ob die Webpage eingetragen wurde
    Set html = CreateObject("htmlfile")
      html.body.innerhtml = XMLHTTP.ResponseText
        Set objResultDiv = html.getelementbyid("rso")
          Set objH3 = objResultDiv.getelementsbytagname("H3")(0)
          Set link = objH3.getelementsbytagname("a")(0)
    Cells(i, 8) = link.href
'=================================================================================================================================
'Überprüft alle Neuen Firmen ob die Tel eingetragen wurde
  str_text = VBA.Mid(html.body.innerhtml, VBA.InStr(html.body.innerhtml, strVorNr) + VBA.Len(strVorNr))
    If VBA.InStr(str_text, strNachNr) > 0 Then
      str_text = VBA.Mid(str_text, 1, VBA.InStr(str_text, strNachNr) - 1)
    End If
  Cells(i, 7) = "+49 " & (VBA.Trim(str_text))
Next
  Application.ScreenUpdating = True
End Sub

Beim Rot markierten habe Ich die anzeige eingebaut, sie geht aber nicht.

Live is a Game Play it

[Steffl]

Hallo Florian,

heißt dein Userform auch GoogleSuche? Und gibt es da zwei Label? Eins mit dem Namen Label1 das andere mit dem Namen Label3? Ist bei beiden die Visible-Eigenschaft auf True? Du startest das ganze schon aus der Userform selber?

Nachtrag:

Das

Code:

lastRow = Range("A" & Rows.Count).End(xlUp).Row
  GoogleSuche.Label1.Width = 0
For i = i + 1 To lastRow
If lastRow = ("STEFFEN SCHULZ") Or ("GERALD BÖHM") Or ("HANS TRAUTMANN") Or ("WALTER SCHIMMEL") Then

ist läuft nicht!

[Florian20]

1. Ja heißt es
2. nein es gibt 3
3. muss die Labels noch ordnen
4. die Eigenschaft ist true
5. ja mache ich

Ja das weiß Ich das die "ist" Bedingung nicht geht  :19:

lg flo

[Steffl]

Hallo Florian,

Ja das weiß Ich das die "ist" Bedingung nicht geht  :19:

da wollte ich eigentlich schreiben: "Das ist völliger Quatsch". Nachdem das schon hart ist habe ich leider nur den völligen Quatsch entfernt und was geschrieben, wo das "ist" nicht mehr paßt.