Ladebalken mit VBA

Hallo ich habe hie rim Forum folgenden Code gefunden um Ladebalken azeigen zu lassen:
Wie bekomme ich meinen Code mit dem der den Ladebalken generiert zusaammen ?
Ladebalken Code:
Option Explicit
Public SW As Long
Public iMonat, iJahr As Long
Public anzTage, anzDaten As Long
Dim Schritt, Schritt1, Schritt2 As Double
Dim Länge, Länge1, Länge2 As Double
Dim i, z As Long
Dim j As Integer
Dim Spalte As Integer
Dim Farbe As Integer
Dim Tag As Integer
Sub Progressbar1()
SW = 3005 'Schrittweite festlegen
Länge = 0
Schritt = PB1.Label1.Width / SW 'Schrittbreite pro Aktualisierung
For i = 5 To SW
Cells(i, 1) = "Zeile " & i
Cells(i, 1).Interior.ColorIndex = 6
Länge = Länge + Schritt
PB1.Label2.Width = Länge
PB1.Label3.Caption = Format(i / SW, "0 %")
DoEvents
Next
Application.Wait (Now + TimeValue("0:00:2"))
Unload PB1
End Sub
Sub Progressbar2()
SW = 505
Länge1 = 0
Länge2 = 0
Schritt1 = PB2.Label1.Width / 10
Schritt2 = PB2.Label3.Width / SW
Farbe = 1
For j = 3 To 12
For i = 5 To SW
Cells(i, j).Interior.ColorIndex = Farbe
Farbe = Farbe + 1
If Farbe > 15 Then Farbe = 1
Länge2 = Länge2 + Schritt2
PB2.Label5.Width = Länge2
PB2.Label6.Caption = Format(i / SW, "0 %")
DoEvents
Next i
Länge2 = 0
Länge1 = Länge1 + Schritt1
PB2.Label2.Width = Länge1
PB2.Label3.Caption = Format((j - 2) / 10, "0 %")
DoEvents
Next j
Application.Wait (Now + TimeValue("0:00:2"))
Unload PB2
End Sub
Sub Progressbar3()
SW = 505
Länge1 = 0
Länge2 = 0
Schritt1 = PB3.Label1.Width / SW / 10
Schritt2 = PB3.Label3.Width / SW
Farbe = 1
For j = 3 To 12
For i = 5 To SW
Cells(i, j).Interior.ColorIndex = Farbe
Farbe = Farbe + 1
If Farbe > 15 Then Farbe = 1
Länge1 = Länge1 + Schritt1
PB3.Label2.Width = Länge1
PB3.Label3.Caption = Format(i / SW / 10 + (j - 3) / 10, "0 %")
Länge2 = Länge2 + Schritt2
PB3.Label5.Width = Länge2
PB3.Label6.Caption = Format(i / SW, "0 %")
DoEvents
Next i
Länge2 = 0
Next j
Application.Wait (Now + TimeValue("0:00:2"))
Unload PB3
End Sub
Sub Progressbar4()
SW = 100
Länge1 = 0
Länge2 = 0
Schritt1 = PB4.Label1.Width / anzTage
Schritt2 = PB4.Label3.Width / SW
Farbe = 1
Tag = 1
For j = 3 To anzTage + 2
Cells(5, j) = Tag
Tag = Tag + 1
For i = 6 To SW + 6
Cells(i, j).Interior.ColorIndex = Farbe
Farbe = Farbe + 1
If Farbe > 15 Then Farbe = 1
Länge2 = Länge2 + Schritt2
PB4.Label5.Width = Länge2
PB4.Label6.Caption = Format((i - 6) / SW, "0 %")
DoEvents
Next i
Länge2 = 0
Länge1 = Länge1 + Schritt1
PB4.Label2.Width = Länge1
PB4.Label3.Caption = Format((j - 2) / anzTage, "0 %")
PB4.Label7 = "abgearbeitete Tage: " & Tag & " von " & anzTage
DoEvents
Next j
Application.Wait (Now + TimeValue("0:00:2"))
Unload PB4
End Sub Mein Code der éinen Datenabgleich veranlasst:


Public Sub SearchEmploymentDate()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Dim lngRow As Long
Dim strFirstAddress As String, strMachine As String, strEmployee As String
Dim dtmMaxDate As Date
Dim objCell As Range
With ThisWorkbook.Worksheets("AuswertungDatum")
For lngRow = 1 To .Cells(.Rows.Count, 4).End(xlUp).Row
If Not IsEmpty(.Cells(lngRow, 4).Value) And .Cells(lngRow, 2).MergeCells Then
strEmployee = .Cells(lngRow, 4).Value
strMachine = .Cells(lngRow, 2).MergeArea.Cells(1)
dtmMaxDate = 0
With ThisWorkbook.Worksheets("ErfassungEinstätze")
Set objCell = .Columns(6).Find(What:=strEmployee, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=True)
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
If strMachine = objCell.Offset(0, -2).Value Then
If IsDate(objCell.Offset(0, -3).Value) Then
dtmMaxDate = Application.max(dtmMaxDate, CDate(objCell. _
Offset(0, -3).Value))
Else
Call MsgBox(Prompt:="Fehler in Tabelle: ''ErfassungEinstä _
tze'' Zeile: " & _
CStr(objCell.Row) & vbLf & vbLf & "Bitte Eintrag in  _
Spalte C prüfen.", _
Buttons:=vbCritical, Title:="Programmabbruch")
Set objCell = Nothing
Exit Sub
End If
End If
Set objCell = .Columns(6).FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
End If
Set objCell = Nothing
End With
If dtmMaxDate  0 Then
If IsDate(.Cells(lngRow, 6).Value) Then
If .Cells(lngRow, 6).Value

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Alexander,
hier mal ein einfaches Beispiel für einen Laufbalken. Vielleicht kannst Du den ja brauchen.
Allerdings der Code alleine reicht hier nicht, da Du noch eine UF benötigst, in der der Laufbalken enthalten ist. Deshalb lade ich noch eine Datei mit hoch.
Für den Betrieb brauchst Du die Betriebsarten Init, GoOn und Exit bzw. Close, die passend aus Deinem code aufgerufen werden müssen.

Option Explicit

Option COMPARE TEXT

#If Win64 Then

 Declare PtrSafe Function Sleep Lib "kernel32" (ByVal dwmilliseconds As Long) As Long

 Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

 Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

 Global hWnd     As LongPtr

#Else

 Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)

 Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

 Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

 Global hWnd     As Long

#End If

Const HWND_TOPMOST = -1

Const HWND_NOTOPMOST = -2

Const cFLAGS = &H2 Or &H1

Dim gbAbbruch As Integer

Public Const ciAbbruch = 5

Sub FortschrittsDlg(Art As Byte, Schritt As Integer, Optional FSText As String, _

    Optional CPText As String, Optional bOnTop As Boolean)

'Fortschrittsanzeige anzeigen, incl AllwaysOntop

'Art: 0=Init, 1=GoOn, 2=Close, 3=Exit

 Dim ScaleWert

 Static MaxDigits  As Integer

 Static AktWert    As Integer

 With ProzessDlg

   hWnd = FindWindow(vbNullString, .Caption)                        'Handle der Fortschrittsanzeige ermitteln

   Select Case Art

'Dialogbox aufbauen und anzeigen

   Case 0                                                       'Init Dialog

        gbAbbruch = 0: AktWert = 1: MaxDigits = Schritt

        .Prozessfeld.Width = 4

        .Abbrechen.Caption = "Abbrechen"

        .Caption = CPText

        .Show vbModeless

        If bOnTop Then SetWindowPos hWnd, HWND_TOPMOST, 0, 0, 0, 0, cFLAGS

    Case 1                                                      'GoOn

        AktWert = AktWert + Schritt

        ScaleWert = AktWert / MaxDigits * (.Prozessbox.Width - 2)

        If ScaleWert &GT; (.Prozessbox.Width - 2) Then ScaleWert = (.Prozessbox.Width - 2)

        .Prozessfeld.Width = ScaleWert

        If FSText &LT;&GT; "" Then .Aktionstext = FSText

        .Repaint: DoEvents

'Dialogbox schließen oder Schließen-Button aktivieren

   Case 2                                                       'Schließenbutton

        .Prozessfeld.Width = (.Prozessbox.Width - 2)

        If FSText &LT;&GT; "" Then .Aktionstext = FSText

        .Abbrechen.Caption = "Schließen"

        If bOnTop Then SetWindowPos hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, cFLAGS

   Case 3:

        If bOnTop Then SetWindowPos hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, cFLAGS

        .Hide                                                   'Exit

   End Select

 End With

End Sub

Sub Test()

 Dim X As Integer

 FortschrittsDlg 0, 100, "Beginn mit Abarbeitung", "Mein kleiner Fortschrittsbalken", True

 For X = 1 To 50

   Sleep 50

   If X = 25 Then FortschrittsDlg 1, 10, "Neuer Text hier"

  FortschrittsDlg 1, 2

 Next X

 FortschrittsDlg 2, 10, "Klick mich weg"

End Sub

VBA=>HTML, (c) 2018 by KHV

viele Grüße
Karl-Heinz
https://www.herber.de/bbs/user/128090.xlsb

Public Sub SearchEmploymentDate() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim lngRow As Long Dim strFirstAddress As String, strMachine As String, strEmployee As String Dim dtmMaxDate As Date Dim objCell As Range With ThisWorkbook.Worksheets("AuswertungDatum") For lngRow = 1 To .Cells(.Rows.Count, 4).End(xlUp).Row If Not IsEmpty(.Cells(lngRow, 4).Value) And .Cells(lngRow, 2).MergeCells Then strEmployee = .Cells(lngRow, 4).Value strMachine = .Cells(lngRow, 2).MergeArea.Cells(1) dtmMaxDate = 0 With ThisWorkbook.Worksheets("ErfassungEinstätze") Set objCell = .Columns(6).Find(What:=strEmployee, LookIn:=xlValues, _ LookAt:=xlWhole, MatchCase:=True) If Not objCell Is Nothing Then strFirstAddress = objCell.Address Do If strMachine = objCell.Offset(0, -2).Value Then If IsDate(objCell.Offset(0, -3).Value) Then dtmMaxDate = Application.max(dtmMaxDate, CDate(objCell. _ Offset(0, -3).Value)) Else Call MsgBox(Prompt:="Fehler in Tabelle: ''ErfassungEinstä _ tze'' Zeile: " & _ CStr(objCell.Row) & vbLf & vbLf & "Bitte Eintrag in _ Spalte C prüfen.", _ Buttons:=vbCritical, Title:="Programmabbruch") Set objCell = Nothing Exit Sub End If End If Set objCell = .Columns(6).FindNext(After:=objCell) Loop Until objCell.Address = strFirstAddress End If Set objCell = Nothing End With If dtmMaxDate 0 Then If IsDate(.Cells(lngRow, 6).Value) Then If .Cells(lngRow, 6).Value

Sub DeinMakro() Userform_Fortschrittsanzeige.Show vbModeless Userform_Fortschrittsanzeige.Progressbar1.Min = 2 Useffomr_Fortschrittsanzeige.Progressbar1.Max = 1000 For i = 2 to 1000 Userform_Fortschrittsanzeige.Progressbar1.Value = i Userform_Fortschrittsanzeige.Repaint hier dann der Code für die Schleife Next End Sub

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ladebalken mit VBA

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread