Fehler beim Code
13.02.2019 06:08:07
Sebi
ich habe hier einen Code:
Sub Worksheet_Activate()
Dim wksAll As Worksheet
Dim wksYes As Worksheet
Dim wksNo As Worksheet
Set wksAll = Worksheets("MA Grundliste")
Set wksYes = Worksheets("nicht geschult")
Set wksNo = Worksheets("offen")
Dim lastRowAll As Long
Dim lastRowYes As Long
Dim lastRowNo As Long
Dim i As Long
Dim a As Long
Dim strVergleich As String
Dim strArtikel As String
Application.ScreenUpdating = False
'Sheet "verfügbar" ab Zeile 3 löschen
lastRowYes = wksYes.Cells(Rows.Count, 1).End(xlUp).Row
If lastRowYes = 2 Then lastRowYes = 3
wksYes.Range("A3:D" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
'Artikelliste nach "verfügbar" kopieren
lastRowAll = wksAll.Cells(Rows.Count, 1).End(xlUp).Row
wksAll.Range("A3:D" & lastRowAll).Copy Destination:=wksYes.Range("A3")
'Vergleichen und ggf. Zeile löschen
lastRowNo = wksNo.Cells(Rows.Count, 1).End(xlUp).Row
If lastRowNo = 2 Then MsgBox "Personal aktualisiert": GoTo Ende 'nichts zu vergleichen
For i = 3 To lastRowNo
strVergleich = wksNo.Range("A" & i).Value
For a = lastRowAll To 3 Step -1
strArtikel = wksYes.Range("A" & a).Value
If strVergleich = strArtikel Then
wksYes.Rows(a).Delete
End If
Next a
Next i
Ende:
Set wksAll = Nothing
Set wksYes = Nothing
Set wksNo = Nothing
End Sub
mein Problem ist, dass wenn nix drin steht die zweite zeile immer löscht.
Kann man das ändern?
Danke
Anzeige