Bitte Daniel nochmal ! oder auch natürlich...
29.07.2017 18:06:13
philipp
Daniel hatte vorgestern geholfen aber leider klappt es nicht.
Es werden die gefilterten Daten doch nicht eingelesen, warum auch immer.
Hier bleibt stehen:
Me.ListBox1.RemoveItem i
Wieder Laufzeitfehler, nicht näher bezeichneter Fehler.
Irgenwie habe ich wohl einen Fehler eingebaut.
Hier beide Makros:
Private Sub UserForm_Activate()
Dim iIndex As Integer
'--------------- für Bildschirmanpassung --------------------------------------
Dim hwndForm As Long, hwndMenu As Long
Dim intY, intLast, intNext As Integer
On Error Resume Next
With UserForm1
.StartUpPosition = 0
.Top = 0
.Left = 0
.Height = GetDeviceCaps(GetDC(0&), 8)
.Width = GetDeviceCaps(GetDC(0&), 10)
End With
ReleaseDC 0, GetDC(0&)
hwndForm = FindWindow(vbNullString, Me.Caption)
'------------ ab hier festgelegt, UF kann nicht verschoben werden ----------------
'If hwndForm 0 Then
' hwndMenu = GetSystemMenu(hwndForm, 0)
' If hwndMenu 0 Then DeleteMenu hwndMenu, &HF010, &H0
' End If
Dim sBlattname As String
sBlattname = ActiveSheet.Name
Label111.Caption = Label111.Caption
TextBox7.Value = Format(TextBox7.Value, "0.0")
TextBox8.Value = Format(TextBox8.Value, "#,##0.00")
TextBox9.Value = Format(TextBox9.Value, "0.00") 'mietzins pro monat
Label110.Caption = Format(Label110.Caption, "0.00")
TextBox10.Value = Format(TextBox10.Value, "#,##0.00")
Label8.Caption = "Anzahl der Mietwohnungen: " & ActiveSheet.Range("D1")
With ListBox1 ' betrifft die ListBox1
' .Height = 62 ' die Höhe festlegen
' .Left = 20 ' den linken Randabstand festlegen
' .Top = 12 ' den oberen Randabstand festlegen
' .Width = 460 ' die Breite festlegen
.Font.Size = 9 ' die Schriftgröße festlegen
.ForeColor = RGB(0, 0, 255) ' Schriftfarbe immer mit RGB
.ColumnCount = 14 ' die Anzahl der Spalten festlegen
' die Breite der Spalten festlegen
.ColumnWidths = _
("0,7 cm;1,5 cm;2 cm;4 cm;3,5 cm;2,5 cm;1 cm;1,5 cm;1,3 cm;1,5 cm;1,2 cm;3,5 cm;3 cm;1cm") _
.Clear ' die ListBox leeren mzpqm nkp plz ort str nr.
.Column = aTmp
End With
Dim LoLetzte2 As Long
Dim lngI As Long
Dim i
' Me.ListBox1.List = Sheets(sBlattname).Range("A3:N" & LoLetzte2).Value ' neu daniel
' Label8.Caption = "Anzahl der Mietwohnungen: " & (lLetzte - 2)
If Not ActiveSheet.AutoFilterMode Then
LoLetzte2 = Sheets(sBlattname).Cells(Rows.Count, 1).End(xlUp).Row
Me.ListBox1.RowSource = sBlattname & "!A3:N" & LoLetzte2
ComboBox1.AddItem "Alle anzeigen"
For lngI = 0 To ListBox1.ListCount
ComboBox1.AddItem ListBox1.Column(1, lngI)
Next
' ComboBox1.ListIndex = 0
Label115.Caption = ""
Else
ActiveSheet.Range("D1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(2,R3C1:R65000C1)"
Label115.Caption = "gefilterte: " & ActiveSheet.Range("D1")
For i = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.List(i, 1) ComboBox1.Text Then ListBox1.RemoveItem i
Next
End If
TextBox2.SetFocus
End Sub
im Makro ComboBox bleibt da stehen:Me.ListBox1.RemoveItem i
Wieder Laufzeitfehler, nicht näher bezeichneter Fehler.
Private Sub ComboBox1_Change()
Dim LoLetzte2 As Long
Dim LoLetzte1 As Long
Dim i
Dim lngI As Long
Dim sBlattname As String
sBlattname = ActiveSheet.Name
CommandButton2.Enabled = False ' den Änder-Button sperren
CommandButton3.Enabled = False ' den Änder-Button sperren
CommandButton4.Enabled = False ' den Lösch-Button sperren
ActiveSheet.Range("$A$2:$N$2").AutoFilter Field:=2, Criteria1:=ComboBox1.Text
'"*", VisibleDropDown:=False
'ListBox1.List = ActiveSheet.Range("A3:N200").Value ' neu daniel
For i = ListBox1.ListCount - 1 To 0 Step -1
If Me.ListBox1.List(i, 1) ComboBox1.Text Then Me.ListBox1.RemoveItem i
Next
If ComboBox1.ListIndex = 0 Then
ActiveSheet.Range("$A$2:$N$2").AutoFilter Field:=2
If ActiveSheet.AutoFilterMode Then
Selection.AutoFilter
End If
Call UserForm_Activate
End If
If ActiveSheet.AutoFilterMode Then
ActiveSheet.Range("D1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(2,R3C1:R65000C1)"
Label115.Caption = "gefilterte: " & ActiveSheet.Range("D1")
Else
Label115.Caption = ""
CommandButton2.Enabled = True
CommandButton3.Enabled = True
CommandButton4.Enabled = True
End If
End Sub
grußphilipp b