Habe ich mir beinahe gedacht!
nur der genaue Punkt, den kann ich nicht zuordnen. Wenn ich die Dokumente wie im Code aus der ListBox
lade, bearbeite und dann Bspw. den Haken setze für Daten auswählen die nach Outlook gebracht werden.
ich das Form schließe, dann beginnt die Eieruhr unaufhörlich zu laufen, klicke ich auf das Tabellenblatt beruhigt sich die Eieruhr wieder, starte ich die Form wieder dann ist (könnte es der Punkt sein wo nichts mehr geht. In der Regel sagt mir Excel könne nicht beendet werden.
Code:
Private Sub UserForm_Activate()
Call Fuellen_Lieferant
Call Fuellen_Vermerk
Me.txtSendeDat = Date
End Sub
Sub Fuellen_Lieferant()
Dim col As New Collection
Dim iRow As Long, ALetzte As Long
ALetzte = IIf(IsEmpty(Range("A65536")), Range("A65536").End(xlUp).Row, 65536)
On Error Resume Next
cboLieferant.Clear
For iRow = 4 To ALetzte
If Not IsEmpty(Cells(iRow, 5)) Then
col.Add Cells(iRow, 5), Cells(iRow, 5)
If Err = 0 Then
cboLieferant.AddItem Cells(iRow, 5)
Else
Err.Clear
End If
End If
Next iRow
On Error GoTo 0
Call Sortieren1
On Error Resume Next
cboLieferant.ListIndex = 0
End Sub
Sub Fuellen_Vermerk()
Dim col As New Collection
Dim iRow As Long, ALetzte As Long
ALetzte = IIf(IsEmpty(Range("A65536")), Range("A65536").End(xlUp).Row, 65536)
On Error Resume Next
cboVermerk.Clear
For iRow = 4 To ALetzte
If Not IsEmpty(Cells(iRow, 7)) Then
col.Add Cells(iRow, 7), Cells(iRow, 7)
If Err = 0 Then
cboVermerk.AddItem Cells(iRow, 7)
Else
Err.Clear
End If
End If
Next iRow
On Error GoTo 0
Call Sortieren2
On Error Resume Next
cboVermerk.ListIndex = 0
End Sub
Sub Sortieren1()
Dim Letzter As Integer, Naechster As Integer
Dim i As String
With cboLieferant
For Letzter = 0 To .ListCount - 1
For Naechster = Letzter + 1 To .ListCount - 1
If .List(Letzter) > .List(Naechster) Then
i = .List(Letzter)
.List(Letzter) = .List(Naechster)
.List(Naechster) = i
End If
Next Naechster
Next Letzter
End With
End Sub
Sub Sortieren2()
Dim Letzter As Integer, Naechster As Integer
Dim i As String
With cboVermerk
For Letzter = 0 To .ListCount - 1
For Naechster = Letzter + 1 To .ListCount - 1
If .List(Letzter) > .List(Naechster) Then
i = .List(Letzter)
.List(Letzter) = .List(Naechster)
.List(Naechster) = i
End If
Next Naechster
Next Letzter
End With
End Sub
Private Sub UserForm_Initialize()
Dim fso As FileSystemObject
Dim fol As Folder
Dim fil As File
Dim rngZelle As Range
'Status
Dim dLabel1 As Double
Dim dLabel2 As Double
Dim dBreite As Double
Dim dSumme As Double
Dim dWidth1 As Double
Dim dWidth2 As Double
If Worksheets("admin").Range("H1").Value "" Then
If IsNumeric(Worksheets("admin").Range("H1").Value) Then
dLabel1 = CDbl(Worksheets("admin").Range("H1").Value)
Else
MsgBox "Der 1. Wert in Zelle ""H1"" ist nicht nummerisch.", _
48, " Hinweis für " & Application.UserName
Exit Sub
End If
Else
MsgBox "Es gibt keinen 1. Wert in Zelle ""H1""", _
48, " Hinweis für " & Application.UserName
Exit Sub
End If
If Worksheets("admin").Range("H2").Value "" Then
If IsNumeric(Worksheets("admin").Range("H2").Value) Then
dLabel2 = CDbl(Worksheets("admin").Range("H2").Value)
Else
MsgBox "Der 2. Wert in Zelle ""H2"" ist nicht nummerisch.", _
48, " Hinweis für " & Application.UserName
Exit Sub
End If
Else
MsgBox "Es gibt keinen 2. Wert in Zelle ""H2""", _
48, " Hinweis für " & Application.UserName
Exit Sub
End If
dBreite = Label118.Width + Label119.Width ' Breite beider Label
dSumme = dLabel1 + dLabel2 ' Summe aus Zelle H1 + Zelle _
H2 = 100%
dWidth1 = dLabel1 / dSumme * 100 ' prozentualer Anteil Zelle H1
dWidth2 = dLabel2 / dSumme * 100 ' prozentualer Anteil Zelle H2
With Label118 ' für Label 1
.Left = 174 ' Start-Position für Label 1
.Width = dBreite * dWidth1 / 100 ' prozentualer Anteil an _
beiden Label-Width
.Caption = Format(dLabel1 / dSumme * 100, "##0.00") & " %" ' die Prozente anzeigen
.Font.Size = 8 ' die Schriftgröße
End With
With Label119 ' für Label 2
.Left = (dBreite * dWidth1 / 100) + 174 ' Start-Position ist Label 1. _
Width
.Width = dBreite - Label118.Width ' restliche Gesamtbreite - _
Label 1.Width
.Caption = Format(dLabel2 / dSumme * 100, "##0.00") & " %" ' die Prozente anzeigen
.Font.Size = 8 ' die Schriftgröße
End With
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ _
strPath = ActiveWorkbook.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set fol = fso.GetFolder(strPath)
For Each fil In fol.Files
If LCase(Right(fil.Name, 3)) = "xls" Then
lstTOC.AddItem fil.Name
End If
Next fil
Me.txtStatus = Date
For Each fil In fol.Files
If LCase(Right(fil.Name, 3)) = "jpg" Then
BildBox.AddItem fil.Name
End If
Next fil
For Each fil In fol.Files
If LCase(Right(fil.Name, 3)) = "pdf" Then
PDFBOX.AddItem fil.Name
End If
Next fil
For Each rngZelle In Range(Cells(4, 5), Cells(Cells(Rows.Count, 5).End(xlUp).Row, 5))
If rngZelle.Value "" Then
cboLieferant.AddItem rngZelle.Value
End If
Next rngZelle
For Each rngZelle In Range(Cells(4, 7), Cells(Cells(Rows.Count, 7).End(xlUp).Row, 7))
If rngZelle.Value "" Then
cboVermerk.AddItem rngZelle.Value
End If
Next rngZelle
'For Each rngZelle In Range(Cells(4, 6), Cells(Cells(Rows.Count, 6).End(xlUp).Row, 6))
'If rngZelle.Value "" Then
' cboSonstiges.AddItem rngZelle.Value
'End If
'Next rngZelle
opt_alle.Value = True
Label116 = Sheets("admin").Cells(1, 6).Value & " fehlerhafte Bauteile in Datenbank!"
lblerledigt = Sheets("admin").Cells(1, 8).Value & " erledigt, 8D-Report vorhanden! "
lbloffen = Sheets("admin").Cells(2, 8).Value & " offen, 8D-Report n. vorhanden! "
End Sub