Herbers Excel-Forum - das Archiv

Mehrfach vergleichen

Bild

Betrifft: Mehrfach vergleichen
von: ah

Geschrieben am: 21.03.2005 09:42:55
Guten morgen,
habe ein kleines Problemchen,
habe ein MAkro, welches mir zwei TAbellen vergleicht, jedoch vergleicht es nur einmal und dann nicht mehr, wenns die gleiche Tabelle ist.
Es soll aber immer wieder vergleichen und immer wieder es hin schreiben.
D.h. das Makro vergleicht.Ich lasse es nochmal laufen und es vergleicht nochmal und uberschreibt die Werte nicht, sondern schreibt mir die nächsten werte in die nächste freie Zeile.
Uch hoffe, dass das einigermaßen verständlich war.
Hier der Code
Sub Vergleichen()
Dim LoI As Long
Dim LoLetzte1 As Long
Dim Loletzte3 As Long
Dim c As Object
Dim z%
With Worksheets("sheet1")
LoLetzte1 = IIf(IsEmpty(.Range("B65536")), .Range("B65536").End(xlUp).Row, 65536)
End With
For LoI = 1 To LoLetzte1    'Sheet1 wird durchlaufen und mit Verweis verglichen!!!
' Leerzellen nicht kennzeichnen
Set c = Worksheets("Übersicht").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2).Value, lookat:=xlWhole)
If Worksheets("sheet1").Cells(LoI, 2).Value <> "" And c Is Nothing Then
Set c = Worksheets("Verweis").Columns(1).Find(what:=Worksheets("sheet1").Cells(LoI, 2).Value, lookat:=xlWhole)
If Not c Is Nothing Then
startzeile = LoI
summe = Worksheets("sheet1").Cells(LoI, 3).Value
z = 1
zeile = LoI
Do
Set c = Worksheets("sheet1").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2), after:=Worksheets("sheet1").Cells(zeile, 2), lookat:=xlWhole)
If c.Row <> startzeile Then
summe = summe + Worksheets("sheet1").Cells(c.Row, 3).Value
z = z + 1
zeile = c.Row
End If
Loop Until c.Row = startzeile
Worksheets("sheet1").Rows(LoI).Copy
With Worksheets("Übersicht")
Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
If Loletzte3 > 65536 Then
MsgBox "In Tabelle3 ist keine Zeile mehr frei"
Application.CutCopyMode = False
Exit Sub
End If
.Rows(Loletzte3).PasteSpecial Paste:=xlValues           ' Werte
.Rows(Loletzte3).PasteSpecial Paste:=xlFormats      ' Formate
.Cells(Loletzte3, 3).Value = summe
.Cells(Loletzte3, 4).Value = z
End With
End If
End If
Next LoI
Application.CutCopyMode = False
End Sub

Vielen DAnk
ah
Bild

Betrifft: AW: Mehrfach vergleichen
von: ChrisSp

Geschrieben am: 21.03.2005 09:58:35
Hi Artur ;o),
in der Zeile: *If Worksheets("sheet1").Cells(LoI, 2).Value <> "" And c Is Nothing Then* wird überprüft, ob die Werte im Blatt ("Übersicht") schon vorhanden sind (= *c is nothing*), c wird in der Zeile dadrüber ermittelt. Wenn du also das * and c is nothing* entfernst, erfolgt diese Prüfung nicht, dann sollte es immer wieder reingeschrieben werden - wenn ich mich richtig erinnere
Gruss
Chris
Bild

Betrifft: AW: Mehrfach vergleichen
von: ah

Geschrieben am: 21.03.2005 10:08:32
Hi Chris, so schnell sieht man sich wieder.
Habe "c is nothing" enfernt, und es klappt, dass er es nochmal hinschreibt. Nur schreibt er jetzt die Werte nicht einmal, sondern so of sie vorkommen hin.
Er soll sie aber nur einmal hinschreiben und und dann die Anzahl dazu und die Summe.
Was sagst du dazu?
MFG
ah
Bild

Betrifft: AW: Mehrfach vergleichen
von: ChrisSp

Geschrieben am: 21.03.2005 10:42:53
... hatte gerade einen kleinen BlackOut - aber hab´s doch noch hinbekommen.
folgende Änderung:
Sub Vergleichen()
Dim LoI As Long
Dim LoLetzte1 As Long
Dim Loletzte3 As Long
Dim c As Object
Dim z%, zielZeile%
With Worksheets("sheet1")
LoLetzte1 = IIf(IsEmpty(.Range("B65536")), .Range("B65536").End(xlUp).Row, 65536)
End With
For LoI = 1 To LoLetzte1    'Sheet1 wird durchlaufen und mit Verweis verglichen!!!
' Leerzellen nicht kennzeichnen
Set c = Worksheets("Übersicht").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2).Value, lookat:=xlWhole)
If Worksheets("sheet1").Cells(LoI, 2).Value <> "" And c Is Nothing Then
Set c = Worksheets("Verweis").Columns(1).Find(what:=Worksheets("sheet1").Cells(LoI, 2).Value, lookat:=xlWhole)
If Not c Is Nothing Then
startzeile = LoI
summe = Worksheets("sheet1").Cells(LoI, 3).Value
z = 1
zeile = LoI
Do
Set c = Worksheets("sheet1").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2), after:=Worksheets("sheet1").Cells(zeile, 2), lookat:=xlWhole)
If c.Row <> startzeile Then
summe = summe + Worksheets("sheet1").Cells(c.Row, 3).Value
z = z + 1
zeile = c.Row
End If
Loop Until c.Row = startzeile
Worksheets("sheet1").Rows(LoI).Copy
With Worksheets("Übersicht")
Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
If Loletzte3 > 65536 Then
MsgBox "In Tabelle3 ist keine Zeile mehr frei"
Application.CutCopyMode = False
Exit Sub
End If
.Rows(Loletzte3).PasteSpecial Paste:=xlValues           ' Werte
.Rows(Loletzte3).PasteSpecial Paste:=xlFormats      ' Formate
.Cells(Loletzte3, 3).Value = summe
.Cells(Loletzte3, 4).Value = z
End With
End If
ElseIf Worksheets("sheet1").Cells(LoI, 2).Value <> "" And Not c Is Nothing Then
zielZeile = c.Row
startzeile = LoI
summe = Worksheets("sheet1").Cells(LoI, 3).Value
z = 1
zeile = LoI
Do
Set c = Worksheets("sheet1").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2), after:=Worksheets("sheet1").Cells(zeile, 2), lookat:=xlWhole)
If c.Row <> startzeile Then
summe = summe + Worksheets("sheet1").Cells(c.Row, 3).Value
z = z + 1
zeile = c.Row
End If
Loop Until c.Row = startzeile
Sheets("Übersicht").Cells(zielZeile, 3).Value = summe
Sheets("Übersicht").Cells(zielZeile, 4).Value = z
End If
Next LoI
Application.CutCopyMode = False
End Sub

Dadurch werden die Summe und die Anzahl immer wieder aktualisiert!
Der Teil ab: * ElseIf....* ist dafür verantwortlich

Gruss
Chris
Bild

Betrifft: AW: Mehrfach vergleichen
von: ah
Geschrieben am: 21.03.2005 10:50:18
Hi chris,
vielen dank für deine Mühe, aber irgendwie funktioniert das nicht.
Habs eben probiert und es ist genau so wie früher.
Er schreibt es nur einmal hin, nachdem ich es mehrmals laufen lasse.
Woran kanns liegen?
MFG
ah
Bild

Betrifft: AW: Mehrfach vergleichen
von: ChrisSp

Geschrieben am: 21.03.2005 10:56:40
??? bei mir hat´s geklappt ???
Hast du einen neuen Wert eingetragen oder mal den zu summierenden Wert ("sheet1", spalte C) verändert?
Das Makro läuft jetzt so, dass es schaut, ob der Wert (z.B. "GSB MODUL 3") schon vorhanden ist, wenn ja, dann werden die Summe und die Anzahl für den Wert neu ermittelt und diese Werte im Sheet "Übersicht" aktualisiert, es wird also keine neue Zeile geschrieben
Gruss
Chris
Bild

Betrifft: AW: Mehrfach vergleichen
von: ah

Geschrieben am: 21.03.2005 11:04:47
Hi Chris,
ich glaub es war in Missverständnis, ich wollte nicht dass es die Daten aktualisiert sondern einfach nur immmer wieder hin schreibt, wenn ich das makro laufen lasse.
Das hat den Hintergrund, dass ich eine Monatsaufstellung machen werde und immer wieder ein neues "sheet1 einfügen werde.
Aber am besten schau dir die Mappe an.
https://www.herber.de/bbs/user/19931.xls

Früher, bei meinem ersten Code hat es einfach immmer wennn ich auf das Makro laufen gelassen habe, einfach in die nachste freie zeile geschrieben.
Ich hoffe ich konnte das erklären. Wenn du mir da helfen könntest wäre das super.
MFG
Ah
Bild

Betrifft: AW: Mehrfach vergleichen
von: ChrisSp

Geschrieben am: 21.03.2005 11:24:03
... das macht die Sache etwas komplizierter, aber schon selbst - es sollte jetzt klappen ??? - Hoffentlich :o)
Sub Vergleichen()
Dim LoI As Long
Dim LoLetzte1 As Long
Dim Loletzte3 As Long
Dim c As Object
Dim z%, erf_Obj%, i%
Dim Erfasste_Objekte()
erf_Obj = 0
With Worksheets("sheet1")
LoLetzte1 = IIf(IsEmpty(.Range("B65536")), .Range("B65536").End(xlUp).Row, 65536)
End With
For LoI = 1 To LoLetzte1    'Sheet1 wird durchlaufen und mit Verweis verglichen!!!
'            Set c = Worksheets("Übersicht").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2).Value, lookat:=xlWhole)
If Worksheets("sheet1").Cells(LoI, 2).Value <> "" Then
For i = 1 To erf_Obj
If Erfasste_Objekte(i) = Worksheets("sheet1").Cells(LoI, 2).Value Then
Exit For
End If
Next
If i > erf_Obj Then
'Dieser Wert wurde noch nicht erfasst
erf_Obj = erf_Obj + 1
ReDim Preserve Erfasste_Objekte(erf_Obj)
Erfasste_Objekte(erf_Obj) = Worksheets("sheet1").Cells(LoI, 2).Value
Set c = Worksheets("Verweis").Columns(1).Find(what:=Worksheets("sheet1").Cells(LoI, 2).Value, lookat:=xlWhole)
If Not c Is Nothing Then
startzeile = LoI
summe = Worksheets("sheet1").Cells(LoI, 3).Value
z = 1
zeile = LoI
Do
Set c = Worksheets("sheet1").Columns(2).Find(what:=Worksheets("sheet1").Cells(LoI, 2), after:=Worksheets("sheet1").Cells(zeile, 2), lookat:=xlWhole)
If c.Row <> startzeile Then
summe = summe + Worksheets("sheet1").Cells(c.Row, 3).Value
z = z + 1
zeile = c.Row
End If
Loop Until c.Row = startzeile
Worksheets("sheet1").Rows(LoI).Copy
With Worksheets("Übersicht")
Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
If Loletzte3 > 65536 Then
MsgBox "In Tabelle3 ist keine Zeile mehr frei"
Application.CutCopyMode = False
Exit Sub
End If
.Rows(Loletzte3).PasteSpecial Paste:=xlValues           ' Werte
.Rows(Loletzte3).PasteSpecial Paste:=xlFormats      ' Formate
.Cells(Loletzte3, 3).Value = summe
.Cells(Loletzte3, 4).Value = z
End With
End If
End If
End If
Next LoI
Application.CutCopyMode = False
End Sub

Gruss
Chris
Bild

Betrifft: AW: Mehrfach vergleichen
von: ah
Geschrieben am: 21.03.2005 11:34:19
Hi Chris,tolle Leistung,
du kriegst das immer wieder hin, super.
bis zum nächsten mal! DANKE!!!
MFG
Artur
Bild

Betrifft: Bis zum nächsten Mal :o) oT
von: ChrisSp
Geschrieben am: 21.03.2005 11:37:19
 Bild
Excel-Beispiele zum Thema "Mehrfach vergleichen"
Mehrfachauswahl aus ListBox auslesen Mehrfachnennung melden
Mehrfachauswahl im Hoch- und Querformat drucken Bereiche bei Mehrfachauswahl prüfen
Mehrfachauswahl in ListBox auslesen Mehrfachauswahl aus UserForm-ListBoxes in Tabelle eintragen
Alle mehrfach vorkommenden Datensätze in zweiter Tabelle listen Mehrfachauswahl über Schaltfläche steuern
Blattauswahl über UserForm-ListBox mit Mehrfachauswahl Zellen vergleichen und markieren