Excel vba Daten kopieren wenn Bedingung erfüllt

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Excel vba Daten kopieren wenn Bedingung erfüllt
von: Crizz
Geschrieben am: 21.05.2015 13:40:22

Hallo allen zusammen,
ich arbeute an einem Makro der Daten von einem Tabellenblatt ins andere kopieren soll mit der Bedingung das vier Felder auf Ungleichheit geprüft werden sollen. Sind die Felder vom Tabellenblatt "Datenblatt" nicht gleich den vom Tabellenblatt "MBC" soll die ganze Zeile von "Datenblatt" nach "MBC" in die nächst freie Zeile kopiert werden.
Mein Code hierfür sieht folgendermaßen aus:

  • 
    Sub Aktualisieren()
    Dim eintragCheck1 As Variant
    Dim eintragCheck2 As Variant
    Dim eintragCheck3 As Variant
    Dim eintragCheck4 As Variant
    Dim eintragCheck10 As Variant
    Dim eintragCheck20 As Variant
    Dim eintragCheck30 As Variant
    Dim eintragCheck40 As Variant
    Dim leereZeile
    Application.ScreenUpdating = False
    For Zähler = 4 To Sheets("Datenblatt").Cells(Rows.Count, 1).End(xlUp).Row
    Sheets("Datenblatt").Range("A" & Zähler, "L" & Zähler).Copy
    Sheets("MBC").Activate
            For j = 4 To Sheets("MBC").Cells(Rows.Count, 7).End(xlUp).Row
            
            eintragCheck10 = Sheets("MBC").Cells(j, 2).Value
            eintragCheck20 = Sheets("MBC").Cells(j, 5).Value
            eintragCheck30 = Sheets("MBC").Cells(j, 6).Value
            eintragCheck40 = Sheets("MBC").Cells(j, 7).Value
            
                    For i = 4 To Sheets("Datenblatt").Cells(Rows.Count, 7).End(xlUp).Row
                    eintragCheck1 = Sheets("Datenblatt").Cells(i, 2).Value
                    eintragCheck2 = Sheets("Datenblatt").Cells(i, 5).Value
                    eintragCheck3 = Sheets("Datenblatt").Cells(i, 6).Value
                    eintragCheck4 = Sheets("Datenblatt").Cells(i, 7).Value
                    
                    If eintragCheck1 <> eintragCheck10 And eintragCheck2 <>               _
    eintragCheck20 And eintragCheck3 <> eintragCheck30 And eintragCheck4 <> eintragCheck40 Then
                    leereZeile = Sheets("MBC").Cells(Rows.Count, 7).End(xlUp).Row + 1
                    Sheets("MBC").Range("A" & leereZeile).PasteSpecial          Paste:= _
    xlPasteFormulasAndNumberFormats
                   
                    End If
                                    
                    Next i
             Next j
    Next Zähler
    End Sub


  • Das Problem dabei ist es wird nur eine Zeile kopiert und dann funktioniert nichts mehr. Hoffe ihr könnt mir weiiterhelfen.
    Grüße Chris

    Bild

    Betrifft: AW: Excel vba Daten kopieren wenn Bedingung erfüllt
    von: Michael
    Geschrieben am: 21.05.2015 14:01:11
    Hallo Chris,
    das ohne Daten zu testen ist mir zu viel Aufwand, da sitze ich erst ne halbe Stunde, um was zu basteln.
    Deshalb nur zwei Kommentare: Du schaltest das screenupdating nicht wieder ein, und die Schleifen sind nicht sauber, weil Du die Zielwerte in "MBC" jedesmal neu ermittelst, so daß auch bereits geschriebene Zeilen erneut durchgeackert werden.
    Sauber wäre, die Spaltenlängen zunächst zu ermitteln und in Variablen zu stecken (z.B. bis_mbc) und diese in die For-Schleife zu stecken. Zum Schreiben der neuen Zeilen würde ich eine weitere Zählvariable nehmen, die Du ja mit bis_mbc+1 initialisieren und dann bei jeder geschriebenen Zeile um 1 hochzählen kannst.
    Schöne Grüße,
    Michael

    Bild

    Betrifft: AW:Excel vba Daten kopieren wenn Bedingung erfüllt
    von: Crizz
    Geschrieben am: 21.05.2015 15:29:10
    Hallo Michael,
    danke für den Tip.
    Ich hab es jetzt etwas umgeändert und eine Beispieldatei erzeugt. Noch eine Frage zur Prüfung der Ungleichheit. Ist es möglich da mit dem XOR Operator zu arbeiten? Bei mir wird nämlich alles kopiert.
    Die Datei befindet sich hier:
    https://www.herber.de/bbs/user/97761.xlsm
    Viele Grüße Chris

    Bild

    Betrifft: So vielleicht?
    von: Michael
    Geschrieben am: 21.05.2015 16:54:42
    Hi Chris,
    ich habe das ganze Ding etwas optimiert:

    Option Explicit
    Sub Aktualisieren()
    Dim ergebnis%, sp%(4), ergmax
    Dim j%, i%, k%
    Dim leereZeile
    Dim to_MBC
    Dim to_Datenblatt
    to_MBC = Sheets("MBC").Cells(Rows.Count, 7).End(xlUp).Row
    to_Datenblatt = Sheets("Datenblatt").Cells(Rows.Count, 7).End(xlUp).Row
    leereZeile = to_MBC + 1
    ' Das hier sind die Nummern der Spalten zur Abarbeitung in e. Schleife
    sp(1) = 2
    sp(2) = 5
    sp(3) = 6
    sp(4) = 7
    Application.ScreenUpdating = False
    For i = 4 To to_Datenblatt
      ergmax = 0
      For j = 4 To to_MBC
        ergebnis = 0
        For k = 1 To 4
          ergebnis = ergebnis + Abs((Sheets("Datenblatt").Cells(i, sp(k)).Value = _
            Sheets("MBC").Cells(j, sp(k)).Value) * 1)
        Next k
        If ergebnis > ergmax Then ergmax = ergebnis
      Next j
      ' MsgBox "DB Zeile " & i & " ergmax: " & ergmax
      If ergmax < 4 Then                              ' hier kann man drehen.
        Sheets("Datenblatt").Range("A" & i, "L" & i).Copy
        Sheets("MBC").Range("A" & leereZeile).PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
        leereZeile = leereZeile + 1
      End If
    Next i
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    End Sub
    
    Damit wird der März angehängt.
    Wenn ich es richtig verstehe, ist es ja nicht so, daß nichts angehängt werden soll, sobald *ein* Feld übereinstimmt, sondern nur dann nicht, wenn alle *vier* übereinstimmen. So tut es auch.
    Schöne Grüße,
    Michael

    Bild

    Betrifft: AW: So vielleicht?
    von: Crizz
    Geschrieben am: 26.05.2015 06:39:54
    Hallo Michael,
    funktioniert Prefekt!
    Vielen Dank für deine Hilfe

    Bild

    Betrifft: freut mich, danke für die Rückmeldung owT
    von: Michael
    Geschrieben am: 26.05.2015 16:55:35


     Bild

    Beiträge aus den Excel-Beispielen zum Thema "Excel vba Daten kopieren wenn Bedingung erfüllt"