AW: Per VBA Zeilen löschen
25.06.2020 00:41:03
fcs
Hallo Didi,
hier der Code unter dem Userfom, um einen Auszug der Liste mit der gewählten Kunden-Nummer.
das Blatt "Daten_01" wird in eine neue Arbeitsmappe kopiert, dann werden die Zeilen mit den nicht übereinstimmenden Kudennumemrn gelöscht.
LG
Franz
Private Sub CommandButton1_Click()
' Kundennummer_Suchen Makro
Dim wkbNeu As Workbook, wksNeu As Worksheet, objList As ListObject
Dim varKdNr
Dim strPath As String, strDatei As String
'Prüfen, ob eine Kundennummer gewählt wurde
If Me.ComboBox1.ListIndex = -1 Then
MsgBox "Bitte eine Kundennummer in Combobox auswählen."
Exit Sub
End If
varKdNr = Me.ComboBox1 'Kundennummer einlesen
If MsgBox("Liste zu Kunden-Nr. """ & varKdNr & """ erstellen?", _
vbQuestion + vbOKCancel) = vbCancel Then Exit Sub
'Pfad und Dateiname unter dem die Liste zu Kundennr. gespeichert werden soll
strPath = ActiveWorkbook.Path 'Verzeichnis für die Kundenlisten
strDatei = "Liste Kunde " & varKdNr & Format(Date, " YYYY-MM-DD") & ".xlsx"
'Tabellenblatt mit Liste in neue Mappe kopieren
ActiveWorkbook.Sheets("Daten_01").Copy
Set wkbNeu = ActiveWorkbook
Set wksNeu = wkbNeu.Worksheets(1)
Set objList = wksNeu.ListObjects(1)
'Filter in Liste setzen auf ungleich Kundennummer setzen
objList.Range.AutoFilter Field:=2, Criteria1:="" & varKdNr, Operator:=xlAnd
'sichtbare Kundennummern löschen
wksNeu.Range(objList.Name & "[Kundennummer]").ClearContents
'Filter wieder aufheben
objList.Range.AutoFilter Field:=2
'Liste nach Kundennummer sortieren, so dass alle leeren Zeilen am Listenende stehen
With objList.Sort
.SortFields.Clear
.SortFields.Add2 Key:=wksNeu.Range(objList.Name & "[[#All],[Kundennummer]]"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With wksNeu
'letzte Zeile mit Kundennummer
Zeile_1 = .Cells(objList.Range.Row, 2).End(xlDown).Row
'letzte Zeile mit Daten
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Inhalte Zeilen ohne Kundennummer löschen
.Range(.Rows(Zeile_1 + 1), .Rows(Zeile_L)).Clear
'Größe der Liste anpassen
objList.Resize .Range(.Cells(objList.Range.Row, 1), .Cells(Zeile_1, _
objList.Range.Columns.Count))
End With
'Datei speichern
Application.DisplayAlerts = False 'vorhandene datei mit gleichem Namen wird ohne Rückfrage ü _
berschrieben
wkbNeu.SaveAs Filename:=strPath & "\" & strDatei, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, addtomru:=True
Application.DisplayAlerts = True
'Datei schliessen
wkbNeu.Close
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim oDic As Object, meAr
Dim A As Long
Set oDic = CreateObject("Scripting.Dictionary")
'Tabelle anpassen
With Sheets("Daten_01")
'bereich anpassen, hier ohne Überschrift
meAr = Range("b4", .Cells(.Rows.Count, 3).End(xlUp))
End With
For A = 1 To UBound(meAr)
oDic(meAr(A, 1)) = 0
Next
ComboBox1.List = oDic.keys
End Sub