VBA Userform vbmodless scrollen nicht möglich
19.12.2016 15:21:05
Jendrik
im Zuge meiner Arbeit habe ich aktuell ein Problem, dessen gängige Lösungsvorschläge irgendwie nicht zu helfen scheinen.
Beim Klick auf einen Button wird zunächst eine UserForm mit dem namen "frmStatus" aufgerufen. _
Diese wird als modal=False aufgerufen.
Private Sub cmdCalc_Click()
frmStatus.Show vbModeless
End Sub
Bei Aufruf dieser UserForm wird der Close-Button deaktiviert (das rote x)
Außerdem wird die Position des Userforms definiert und ein paar Variablen/Forms aktiviert oder deaktiviert.
Im Anschluss wird ein Sub gestartet.
Option Explicit
Private Sub cmdCancel_Click()
End
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub
Private Sub UserForm_Initialize()
Dim sngTop As Single, sngLeft As Single
Me.StartUpPosition = 0
sngLeft = Application.Left + Application.Width / 2 - Me.Width / 2
sngTop = Application.Top + Application.Height / 2 - Me.Height / 2
Me.Left = sngLeft
Me.Top = sngTop
End Sub
Private Sub Userform_Activate()
SW = 0
frmStatus.labStatus = ""
frmStatus.Label2.Width = 0
frmStatus.Label5.Width = 0
frmStatus.cmdStatus.Enabled = False
frmStatus.cmdCancel.Enabled = True
frmStatus.labCaution.Caption = "Bitte warten, bis alle Berechnungen durchgeführt wurden!"
frmStatus.labCaution.Caption = frmStatus.labCaution.Caption & vbCrLf & "Bitte nach _
Abschluss aller Berechnungen noch einen Moment warten!"
Call Hit_n_Run
End Sub
Private Sub cmdStatus_Click()
Unload frmStatus
End
End Sub
Die Funktion Hit_n_run ist eine Art "Statuscheck" und ruft nacheinander einzelne Subs auf und _ entnimmt vorher/nachher deren Zeit.
Sub Hit_n_Run()
Application.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten
Dim checkD7, checkD8, checkImport As Boolean
Dim strDatei, strPfad As String
Dim maxcheck As Integer
Dim CalcDges As Variant
Dim CalcTime() As Variant
lastrow = ThisWorkbook.Worksheets("LG_SAP_LT22").Cells(Rows.count, 1).End(xlUp).Row
calcges = ""
checkD7 = False
checkD8 = False
checkImport = False
maxcheck = 1
xy = 1
varfile = ""
varname = ""
varpath = ""
calcstart = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " Prozessablauf des Tools:" & _
_
_
vbTab & vbTab & vbTab & " Startzeit" & " " & "Endzeit" & " || " & "Dauer"
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " -------------------- _
_
_
SW = ((lastrow - 10) * 4) + 3
Länge1 = 0
Länge2 = 0
If MsgBox("Soll eine Datei importiert werden?", vbYesNo) = vbYes Then
checkImport = True
End If
If MsgBox("Soll zusätzlich die Kopfzeile berechnet werden?", vbYesNo) = vbYes Then
checkD7 = True
End If
If MsgBox("Sollen die berechneten Werte in die Langzeit-Liste übertragen werden?", vbYesNo) _
_
_
= vbYes Then
checkD8 = True
End If
If checkD7 = False And checkD8 = False Then
maxcheck = 5
End If
If checkD7 = True Then
maxcheck = 6
End If
If checkD8 = True Then
maxcheck = 7
End If
ReDim CalcTime(1, maxcheck)
CalcTime(1, 0) = CDate(calcstart)
For xy = 1 To maxcheck
If xy = 1 And checkImport = True Then
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Leeren und _
_
_
Import einer Datei:" & vbTab & vbTab & CDate(CalcTime(1, xy - 1))
Call importFile
CalcTime(1, xy) = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " " & CDate( _
CalcTime(1, xy)) & " || " & Format((CDate(CalcTime(1, xy)) - CDate(CalcTime(1, xy - 1))), _
_
"hh:mm:ss")
DoEvents
ElseIf xy = 1 And checkImport = False Then
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Leerung der _
_
_
Berechnungsmappe:" & vbTab & vbTab & CDate(CalcTime(1, xy - 1))
Call clearSpecial
CalcTime(1, xy) = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " " & CDate( _
CalcTime(1, xy)) & " || " & Format((CDate(CalcTime(1, xy)) - CDate(CalcTime(1, xy - 1))), _
_
"hh:mm:ss")
DoEvents
ElseIf xy = 2 Then
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Zuweisung _
_
_
von Schicht und Produkt:" & vbTab & vbTab & CDate(CalcTime(1, xy - 1))
Call Shift_n_Product
CalcTime(1, xy) = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " " & CDate( _
CalcTime(1, xy)) & " || " & Format((CDate(CalcTime(1, xy)) - CDate(CalcTime(1, xy - 1))), _
_
"hh:mm:ss")
DoEvents
ElseIf xy = 3 Then
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Zuweisung _
_
_
von Lagerzonen und Fahrzeit:" & vbTab & CDate(CalcTime(1, xy - 1))
Call CalcZone
CalcTime(1, xy) = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " " & CDate( _
CalcTime(1, xy)) & " || " & Format((CDate(CalcTime(1, xy)) - CDate(CalcTime(1, xy - 1))), _
_
"hh:mm:ss")
DoEvents
ElseIf xy = 4 Then
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Zuweisung _
_
_
von Aufwandscodes:" & vbTab & vbTab & CDate(CalcTime(1, xy - 1))
Call addtimeZuw
CalcTime(1, xy) = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " " & CDate( _
CalcTime(1, xy)) & " || " & Format((CDate(CalcTime(1, xy)) - CDate(CalcTime(1, xy - 1))), _
_
"hh:mm:ss")
DoEvents
ElseIf xy = 5 Then
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Zuweisung _
_
_
von Aufwandszeit:" & vbTab & vbTab & CDate(CalcTime(1, xy - 1))
Call CalcAddtime
CalcTime(1, xy) = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " " & CDate( _
CalcTime(1, xy)) & " || " & Format((CDate(CalcTime(1, xy)) - CDate(CalcTime(1, xy - 1))), _
_
"hh:mm:ss")
DoEvents
ElseIf xy = 6 And checkD7 = True Then
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Berechnung _
_
_
der Kopfzeile:" & vbTab & vbTab & vbTab & CDate(CalcTime(1, xy - 1))
Call actOverv
CalcTime(1, xy) = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " " & CDate( _
CalcTime(1, xy)) & " || " & Format((CDate(CalcTime(1, xy)) - CDate(CalcTime(1, xy - 1))), _
_
"hh:mm:ss")
DoEvents
ElseIf xy = 7 And checkD8 = True Then
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Übertrag in _
_
_
den Langzeitspeicher:" & vbTab & vbTab & CDate(CalcTime(1, xy - 1))
Call Uebertrag
CalcTime(1, xy) = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & " " & CDate( _
CalcTime(1, xy)) & " || " & Format((CDate(CalcTime(1, xy)) - CDate(CalcTime(1, xy - 1))), _
_
"hh:mm:ss")
DoEvents
End If
If xy = maxcheck Then
CalcDges = Format(Now, "hh:mm:ss")
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " ------------ _
_
_
------------------------------------------------------------------------------------------------ _
_
frmStatus.labStatus.Caption = frmStatus.labStatus.Caption & vbCrLf & " Gesamtdauer _
_
_
der Prozedur:" & vbTab & vbTab & vbTab & CDate(calcstart) & " " & CDate(CalcDges) & " _
_
|| " & Format((CDate(CalcDges) - CDate(calcstart)), "hh:mm:ss")
End If
Next xy
frmStatus.cmdCancel.Enabled = False
Application.Wait (Now + TimeValue("00:00:05"))
frmStatus.cmdStatus.Enabled = True
Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
Application.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
End Sub
Allerdings habe ich jetzt das Problem, dass ich nur noch in den Zellen A1:A10 etwas schreiben kann und alle anderen Zellen des Workbooks "eingefroren sind", scrollen ist auch nicht möglich.
Alle anderen Tabellenblätter funktionieren Problemlos und nach speichern und erneut öffnen der Datei funktioniert auch alles einwandfrei.
Folgendes habe ich bisher probiert:
Hat irgendjemand eine Idee, woran das liegen kann - viel wichtiger noch, wie man diesen Umstand beheben kann?
Klar, ich könnte die Datei einfach schließen und erneut öffnen, aber so wirklich der Weisheit letzter Schluss sollte das nicht sein - vielleicht passiert ja irgendwas im Hintergrund, dass ich nicht bedacht hatte?
Vielen Dank bereits im Voraus
MfG
JF