Vergleichen und löschen von doppelten Einträgen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton1_Click() Dim wksGewaehlt As Worksheet Dim wksVergleich As Worksheet Dim Zeile_A As Long Dim rngSuche As Range, rngVergleich As Range, strNr As String If Me.ListBox1.ListIndex = -1 Then MsgBox "Bitte erst einen Monat in der Listbox auswählen!" Exit Sub End If Set wksGewaehlt = ActiveWorkbook.Worksheets(Me.ListBox1.Value) Set wksVergleich = ActiveWorkbook.Worksheets(wksGewaehlt.Index - 1) If MsgBox("Blatt """ & wksGewaehlt.Name & """ vergleichen mit Blatt """ _ & wksVergleich.Name & """?", _ vbOKCancel, "Blatt-Vergleich") = vbCancel Then Exit Sub With wksVergleich Set rngVergleich = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp)) End With With wksGewaehlt For Zeile_A = .Cells(.Rows.Count, 1).End(xlUp).Row To 5 Step -1 strNr = .Cells(Zeile_A, 1) Set rngSuche = rngVergleich.Find(What:=strNr, LookIn:=xlValues, lookat:=xlWhole) If Not rngSuche Is Nothing Then If MsgBox("Zeile " & Zeile_A & " löschen?", vbOKCancel, "Zeile-Löschen") = vbOK Then .Rows(Zeile_A).Delete shift:=xlShiftUp End If End If Next End With End Sub

Private Sub CommandButton1_Click() Dim wksGewaehlt As Worksheet Dim wksVergleich As Worksheet Dim Zeile_A As Long Dim rngSuche As Range, rngVergleich As Range, strNr As String Dim T As Integer If Me.ListBox1.ListIndex = -1 Then MsgBox "Bitte erst einen Monat in der Listbox auswählen!" Exit Sub End If For T = Me.ListBox1.ListIndex To 0 Step -1 Set wksGewaehlt = ActiveWorkbook.Worksheets(Me.ListBox1.Value) Set wksVergleich = ActiveWorkbook.Worksheets(T) If MsgBox("Blatt """ & wksGewaehlt.Name & """ vergleichen mit Blatt """ _ & wksVergleich.Name & """?", _ vbOKCancel, "Blatt-Vergleich") = vbCancel Then Exit Sub With wksVergleich Set rngVergleich = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp)) End With With wksGewaehlt For Zeile_A = .Cells(.Rows.Count, 1).End(xlUp).Row To 5 Step -1 strNr = .Cells(Zeile_A, 1) Set rngSuche = rngVergleich.Find(What:=strNr, LookIn:=xlValues, lookat:=xlWhole) If Not rngSuche Is Nothing Then If MsgBox("Zeile " & Zeile_A & " löschen?", vbOKCancel, "Zeile-Löschen") = vbOK Then .Rows(Zeile_A).Delete shift:=xlShiftUp End If End If Next End With Next End Sub

For T = 0 To Me.ListBox1.ListIndex - 1 Set wksGewaehlt = ActiveWorkbook.Worksheets(Me.ListBox1.Value) Set wksVergleich = ActiveWorkbook.Worksheets(Me.ListBox1.List(T, 0)) 'oder For T = 0 To Me.ListBox1.ListIndex - 1 Set wksGewaehlt = ActiveWorkbook.Worksheets(Me.ListBox1.Value) Set wksVergleich = ActiveWorkbook.Worksheets(T + 1)

Die letzten 2 probleme habe ich geschafft selber zu lösen. Und zwar indem ich For-Schleife so umgeschrieben:
For T = 1 To Me.ListBox1.ListIndex
Soll mit 1 anfangen und dann ist alles OK. :)
Nun, jetzt möchte ich Datei weiter entwickeln, dass sie noch weitere coole Sachen machen kann. Hier die jetzt aktuelle Datei: https://www.herber.de/bbs/user/93564.xlsm
Aufgabenstellung sieht wie folgt aus:
Ich habe jetzt einen zusätzlichen Datenblatt, "MW20141105". Dieser wird dann in der Userform im ListBox3 aufgenommen. Im ListBox2 sind alle Datenblätter mit Monatsnamen drinnen. Der Voragang ist dann wie folgt:
Man wählt ein Monat per Klick aus dem ListBox2 aus, wählt Daatenblatt "MW20141105" aus dem ListBox3 aus und klickt dann auf "Vergleichen". Dieses soll folgendes erzeugen:
Es werden wieder Zellen aus Spalte A von ausgewählten Datenblätter vergliechen. Falls es eine Übereinstimmung gibt, dann sollen Daten aus in den Monatsblatt kopiert werden. Hier ein Bsp.:
Vergleich "Nov" mit "MW20141105". Zelle A5 ("Nov") ist gleich mit Zelle A2 ("MW20141105"). Dann kopieren Zellen B2, C2, D2, E2 und F2 von "MW20141105" in die Zellen K5, L5, M5, N5 und O5 von "Nov". Inhalte von Zellen G2, H2, I2, J2, K2 ("MW20141105") sollen zusammengefügt werden und in die Zelle P5 reingeschrieben. Dann haben wir Zelle A5 ("Nov") mehrmals in der Liste "MW20141105. In diesem Fall soll für das zweite Befund (Zelle A14 in "MW20141105") eine neue Zeile hinter der Zeile 5 im "Nov" eingefugt und auf gleiche Weise dann die Daten kopiert. Und für jedes nächstes Befund eine neue Zeile drunter. Spricht, in diesem Bsp Zelle A5 gibt es 3 mal im Blatt "MW20141105", dann müssen 2 zusätzlichen Zeilen unter der Zelle A5 eingefügt werden und 3 Mal Daten kopiert.
Für mich ist diese eine sehr anspruchsvolle Aufgabe, aber vllt gibt es einen oder anderen hier, der weißt wie es geht. :)
Viel Dank im Voraus!

Hallo Dusan,
da sind jetzt jede Menge zusätzliche Prüfschritte erforderlich und die die Arti-Nr im MW-Blatt müssen in 2 geschachtelten For-Next-Schleifen abgearbitet werden, um die Mehrfachnummern korrekt zu erfassen.
Gruß
Franz

Private Sub CommandButton2_Click()
'Vergleich MW-Blatt mit Monat
Dim wksMW As Worksheet, arrMW() As Boolean
Dim wksMonat As Worksheet
Dim Zeile_MW As Long, Zeile_MW2 As Long, Zeile_MW_L As Long
Dim Zeile_Monat As Long
Dim rngSuche As Range, rngVergleich As Range
Dim strNr As String, strP As String, SpalteMW As Long
If Me.ListBox2.ListIndex = -1 Then
MsgBox "Bitte erst einen Monat in der Listbox auswählen!", , _
"Vergleich Monat-MW-Blatt"
Exit Sub
End If
If Me.ListBox3.ListIndex = -1 Then
MsgBox "Bitte erst einen MW-Blatt in der Listbox auswählen!", , _
"Vergleich Monat-MW-Blatt"
Exit Sub
End If
Set wksMonat = ActiveWorkbook.Worksheets(Me.ListBox2.Value)
Set wksMW = ActiveWorkbook.Worksheets(Me.ListBox3.Value)
If MsgBox("Blatt """ & wksMW.Name & """ vergleichen mit Blatt """ _
& wksMonat.Name & """?", _
vbOKCancel, "Blatt-Vergleich Monat-MW") = vbCancel Then Exit Sub
With wksMW
'letzte Datenzeile in Spalte A des MW-Blattes
Zeile_MW_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Array für Bearbeitungsstatus anlegen
ReDim arrMW(2 To Zeile_MW_L)
'Zeilen im MW-Blatt abarbeiten
For Zeile_MW = 2 To Zeile_MW_L
'prüfen, ob Auftr-Nr. schon übertragen
If arrMW(Zeile_MW) = False Then
strNr = .Cells(Zeile_MW, 1).Text
'Datenbereich mit Auftragsnummern im Monatsblatt
With wksMonat
Set rngVergleich = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'Auftragsnummer im Monatsblatt suchen
Set rngSuche = rngVergleich.Find(What:=strNr, LookIn:=xlValues, _
lookat:=xlWhole)
If Not rngSuche Is Nothing Then
Zeile_Monat = rngSuche.Row
'Zeilen bis zum Listenende im MW nach der Auftr-Nr durchsuchen
For Zeile_MW2 = Zeile_MW To Zeile_MW_L
If .Cells(Zeile_MW2, 1).Text = strNr Then
If Zeile_MW2 > Zeile_MW Then
'Leerzeile einfügen
Zeile_Monat = Zeile_Monat + 1
wksMonat.Rows(Zeile_Monat).Insert shift:=xlShiftDown
'wksMonat.Cells(Zeile_Monat, 1).Value = strNr 'Art-Nr eintragen
End If
'Zellen B bis F in Zeile nach Monatsblatt Spalte K:O kopieren
.Range(.Cells(Zeile_MW2, 2), .Cells(Zeile_MW2, 6)).Copy _
wksMonat.Cells(Zeile_Monat, 11)
'Text in Zellen G bis K zusammenfassen
strP = .Cells(Zeile_MW2, 7).Text
For SpalteMW = 8 To 11
strP = strP & " " & .Cells(Zeile_MW2, SpalteMW).Text
Next
'Text in Spalte P des Monatsblatt eintragen
wksMonat.Cells(Zeile_Monat, 16).Value = strP
arrMW(Zeile_MW2) = True 'Zeile in MW-Blatt als bearbeitet merken
End If
Next
End If
End If
Next
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Vergleichen und löschen von doppelten Einträgen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Vergleichen und löschen von doppelten Einträgen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread