Belegte Zeilen zählen
09.02.2021 09:04:51
Lizzel
ich habe ein Problem beim Zählen, das ich nicht verstehe.
Statt bei 26 belegten Zeilen, im Bereich B30:B58, ein neues Blatt zu erstellen, erstellt er mir ein neues Blatt bei 30 belegten Zeilen.
Kann mir bitte jemand sagen, wo mein Fehler ist?
Danke!
Gruß Lars
Public Sub ElementeUebtragen()
'Öffnet Fenster zum Werte eingeben
Dim i As Long, strSuche As String, loAnz As Long, z As Long
Dim anzahl As Long
Application.ScreenUpdating = False
Call NummernkreisEingeben1
ThisWorkbook.Worksheets("Wartungskarte").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
Range("B7").Value = nummernkreis
ActiveSheet.name = nummernkreis
With Worksheets("WartungskarteErstellen")
For i = 12 To .Cells(.Rows.Count, "A").End(xlUp).Row
strSuche = ""
If UCase(.Cells(i, "B")) = "X" Then
loAnz = Len(.Cells(i, "A")) - Len(Replace(.Cells(i, "A"), " ", ""))
If loAnz > 0 Then
For z = 0 To loAnz
strSuche = strSuche & Split(.Cells(i, "A"), " ")(z) & "*"
Next z
strSuche = "*" & strSuche
Else
strSuche = "*" & .Cells(i, "A") & "*"
End If
If anzahl 1 Then
With Worksheets("Wartungsaufgaben").AutoFilter.Range
.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1). _
Copy
End With
With Sheets(nummernkreis)
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial Paste: _
=xlPasteValues
anzahl = Application.WorksheetFunction.CountA(Range("B30:B58"))
MsgBox anzahl
End With
Else
MsgBox "Fehler: Es ist für " & .Cells(i, "A") & " keine Wartungsaufgabe _
vorhanden."
End If
Else
Call NummernkreisEingeben2
ThisWorkbook.Worksheets("Wartungskarte").Copy After:=ThisWorkbook.Sheets(Sheets. _
Count)
Range("B7").Value = nummernkreis
ActiveSheet.name = nummernkreis
Worksheets("Wartungsaufgaben").Range("A10:J" & Worksheets("Wartungsaufgaben" _
) _
.Cells(Rows.Count, "F").End(xlUp).Row).AutoFilter Field:=1, Criteria1:= _
strSuche
If Worksheets("Wartungsaufgaben").AutoFilter.Range.Columns(1) _
.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
With Worksheets("Wartungsaufgaben").AutoFilter.Range
.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1). _
Copy
End With
With Sheets(nummernkreis)
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial Paste: _
=xlPasteValues
anzahl = Application.WorksheetFunction.CountA(Range("B30:B58"))
End With
Else
MsgBox "Fehler: Es ist für " & .Cells(i, "A") & " keine Wartungsaufgabe _
vorhanden."
End If
End If
End If
Next i
Worksheets("Wartungsaufgaben").Range("A10").AutoFilter
End With
Application.CutCopyMode = False
Call IntervallPrüfen
'WartungskarteErstellen.Show vbModeless
End Sub