Mehrfach vergleichen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
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

Beiträge aus den Excel-Beispielen zum Thema "Mehrfach vergleichen"