AW: Bereinigung eine Firmenliste
12.11.2019 15:29:15
fcs
Hallo Andrzej,
ich hab auch entsprechende Makros zusammengestellt.
Makro "Bereinigen_Firmenliste_einzeln"
löscht die Firmen-ID in der Zeile mit der aktiven Zelle
Für Makro "Bereinigen_Firmenliste_Auswahl" markierst du im Blatt "Firma" erst alle zu löschenden Firmen-ID in einer bestimmten Spalte (in meinem Code Spalte J) mit einem "x".
Dann startest du das Makro und dieses arbeit alle markierten Zeilen ab.
Die Makros kannst du in deiner Persönlichen Arbeitsmappe speichern oder in der Datei mit den Daten.
Für die Einzel-Löschungen legst du in der Schzugriffsleiste am besten eine Schaltfläche an.
LG
Franz
'Code in einem allgemeinen Modul
'entweder in der persönlichen Makro-Arbeitsmappe oder in der Arbeitsmappe mit den Daten
Option Explicit
Private wkb As Workbook, wksFirma As Worksheet, wksMA As Worksheet
Private SpaTempID_F As Long, SpaTempID_MA As Long
Sub Bereinigen_Firmenliste_einzeln()
'Die Firmen-ID in der Zeile mit der aktiven Zelle wird gelöscht
Dim Zeile As Long
Dim bolMA_loeschen As Boolean, bolFa_loeschen As Boolean
If fncCheckWkb(ActiveWorkbook) = False Then Exit Sub
If Not ActiveSheet.Name = wksFirma.Name Then
MsgBox "Das Blatt ""Firma"" muss das aktive Blatt sein, wenn das Makro gestartet wird", _
vbOKOnly, "Makro: Bereinigen_Firmenliste_einzeln"
Exit Sub
End If
Zeile = ActiveCell.Row
If MsgBox(fncMsgText(Zeile), vbQuestion + vbOKCancel, "Firma löschen") _
= vbCancel Then Exit Sub
'alte FirmenID in beiden Blättern in temporärer Spalte speichern
Call Save_OldID(wks:=wksFirma, SpaID_Fa:=1, SpaTemp_ID:=SpaTempID_F)
Call Save_OldID(wks:=wksMA, SpaID_Fa:=1, SpaTemp_ID:=SpaTempID_MA)
bolMA_loeschen = fncBereinigen_Firmenliste(varFirmaID:=wksFirma.Cells(Zeile, 1).Value)
'Firmen-ID-löschen
wksFirma.Cells(Zeile, 1).ClearContents
bolFa_loeschen = True 'Merker setzen
Call IDs_loeschen_Neue_IDs(bolMA:=bolMA_loeschen, bolFa:=bolFa_loeschen)
End Sub
Sub Bereinigen_Firmenliste_Auswahl()
'Die zu löschenden Firmen-ID werden in einer bestimmten Spalte mit x markiert und _
dann vom Makro in einer Schleife abgearbeitet
Dim spaMark As Long, sMark As String
Dim Zeile As Long
Dim bolMA_loeschen As Boolean, bolFa_loeschen As Boolean
spaMark = 10 'Spalte J - Spalte mit Markierung der zu löschenden Firmen-ID ggf. anpassen
sMark = "x" 'Markierungszeichen für zu löschende Firmen-ID - ggf. anpassen
If fncCheckWkb(ActiveWorkbook) = False Then Exit Sub
'alte FirmenID in beiden Blättern in temporärer Spalte speichern
Call Save_OldID(wks:=wksFirma, SpaID_Fa:=1, SpaTemp_ID:=SpaTempID_F)
Call Save_OldID(wks:=wksMA, SpaID_Fa:=1, SpaTemp_ID:=SpaTempID_MA)
With wksFirma
'Zeilen in Blatt "Firma" abarbeiten
For Zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Prüfen, ob Markierung gesetzt
If LCase(.Cells(Zeile, spaMark).Value) = sMark Then
Select Case MsgBox(fncMsgText(Zeile), vbQuestion + vbYesNoCancel, _
"Firma löschen")
Case vbCancel
Exit For
Case vbNo
'nicht löschen
Case vbYes
If bolMA_loeschen = False _
And fncBereinigen_Firmenliste(varFirmaID:=.Cells(Zeile, 1).Value) _
= True Then
'Merker setzen, dass in "Mitarbeiter" gelöscht werden muss
bolMA_loeschen = True
End If
.Cells(Zeile, 1).ClearContents
'Merker setzen, dass in "Firma" gelöscht werden muss
bolFa_loeschen = True
End Select
End If
Next Zeile
End With
Call IDs_loeschen_Neue_IDs(bolMA:=bolMA_loeschen, bolFa:=bolFa_loeschen)
End Sub
Function fncMsgText(ByVal Zeile As Long)
'Meldetext für Sicherheitsabfrage erzeugen
fncMsgText = "Firmen ID: " & wksFirma.Cells(Zeile, 1).Text & vbLf _
& "Name: " & wksFirma.Cells(Zeile, 2).Text & vbLf _
& "Ort: " & wksFirma.Cells(Zeile, 4).Text & vbLf & vbLf _
& "löschen ?"
End Function
Function fncBereinigen_Firmenliste(varFirmaID As Variant) As Boolean
'Firmen-ID in allen Zeilen im Blatt "Mitarbeiter" löschen, wenn übereinstimmend
Dim Zeile
With wksMA
For Zeile = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(Zeile, 1).Value = varFirmaID Then
.Cells(Zeile, 1).ClearContents
fncBereinigen_Firmenliste = True
End If
Next Zeile
End With
End Function
Function fncCheckWkb(wkb As Workbook) As Boolean
'Prüfung, ob Blätter mit den Namen "Firma" und "Mitarbeiter" vorhanden sind
fncCheckWkb = True
If wkb.Sheets(1).Name = "Firma" Then
Set wksFirma = wkb.Sheets(1)
Else
fncCheckWkb = False
End If
If wkb.Sheets(2).Name = "Mitarbeiter" Then
Set wksMA = wkb.Sheets(2)
Else
fncCheckWkb = False
End If
If fncCheckWkb = False Then
MsgBox "Die Arbeitsmappe """ & wkb.Name _
& """ enhält nicht die Blätter ""Firma"" ( 1. Tabellenblatt) " _
& "und ""Mitarbeiter"" (2. Tabellenblatt)", _
vbOKOnly, "Prüfung Namen der Tabellenblätter"
End If
End Function
Sub Save_OldID(wks As Worksheet, SpaID_Fa, SpaTemp_ID As Long)
'alte Firmen-ID in temporäre Spalte kopieren
With wks
SpaTemp_ID = .UsedRange.Column + .UsedRange.Columns.Count
.Columns(SpaID_Fa).Copy .Columns(SpaTemp_ID)
.Cells(1, SpaTemp_ID).Value = "Firmen-Id-alt"
End With
End Sub
Sub IDs_loeschen_Neue_IDs(ByVal bolMA As Boolean, ByVal bolFa As Boolean)
'Zeilen mit gelöschter ID in den Blättern löschen und neue Firmen-IDs generieren
Dim ID_Neu As Long
Dim Zeile As Long
If bolMA = True Then
'Zeilen mit gelöschter Firmen_ID in Blatt Mitarbeiter löschen
With wksMA
.Range(.Cells(2, 1), .Cells(.Rows.Count, 2).End(xlUp).Offset(0, -1)) _
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
End With
End If
With wksFirma
'Zeilen mit gelöschter Firmen_ID in Blatt Firma löschen
If bolFa = True Then
.Range(.Cells(2, 1), .Cells(.Rows.Count, 2).End(xlUp).Offset(0, -1)) _
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp
'Firmen ID neu generieren
ID_Neu = 1 'Startnummmer für Firmen-ID
For Zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(Zeile, 1) = ID_Neu
ID_Neu = ID_Neu + 1
Next
End If
End With
With wksMA
'neue Firmen-ID in Blatt "Mitarbeiter" per Formel übernehmen und durch Werte ersetzen.
With .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'Bereich mit Firmen_ID
.FormulaR1C1 = "=INDEX('" & wksFirma.Name & "'!C1,MATCH(RC" & SpaTempID_MA & ",'" _
& wksFirma.Name & "'!C" & SpaTempID_F & ",0))"
.Calculate
.Value = .Value
End With
'temporäre Spalte mit alten IDs löschen in Blatt Mitarbeiter
.Columns(SpaTempID_MA).Delete
End With
'temporäre Spalte mit alten IDs löschen in Blatt Firma
wksFirma.Columns(SpaTempID_F).Delete
End Sub