Thema Datum  Von Nutzer Rating
Antwort
18.10.2021 13:26:41 Maximilian Ehrhardt
Solved
Blau Schleifen suche
19.10.2021 10:42:11 Nobody
NotSolved
19.10.2021 14:23:58 Maximilian Ehrhardt
NotSolved
19.10.2021 17:28:23 Gast01287
NotSolved
19.10.2021 20:23:54 Nobody
NotSolved

Ansicht des Beitrags:
Von:
Nobody
Datum:
19.10.2021 10:42:11
Views:
90
Rating: Antwort:
  Ja
Thema:
Schleifen suche

Hallo

will man ein möglichst gutes Programm schreiben und nicht lapidar den Rat geben: -  Google mal im Internet, da findest du alles, dauert es seine Zeit!

Schau dir das Ergebnis bitte mal an und sage mir ob du den Code so perfekt im Netz finden kannst.  Ich glaube nicht ... (fast alles ist möglich bei VBA)

mfg Nobody

Sub Zellen_vergleichen()
Dim b As Long, c As Long, n As Long, Txt
Dim AC As Range, lz1 As Long, lz2 As Long
Dim Tb2 As Worksheet, rFind As Range
Set Tb2 = Worksheets("Tabelle2")    '**  Bitte Namen prüfen

With Worksheets("Tabelle1")         '**  Bitte Namen prüfen
    lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
    lz2 = Tb2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    '** Alle Markierungen in Tabelle vorher löschen!!
    Tb2.Columns("B:C").Interior.Color = xlNone          '** eins von beiden auswählen
    Tb2.Columns("B:C").Font.ColorIndex = xlAutomatic
    'Application.ScreenUpdating = False
 
    'Schleife zum suchen von Daten in Tabelle2 Spalte A
    For Each AC In .Range("A2:A" & lz1)
       AC.Select
        Set rFind = Tb2.Columns(1).Find(What:=AC, After:=[a1], LookIn:=xlFormulas, LookAt:= _
            xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True)

        If Not rFind Is Nothing Then    'Wert gefunden
            'bei gefunden zuerst in Spalte B Wert prüfen  (<> Werte markieren)
            If AC.Cells(1, 2) <> rFind.Cells(1, 2) Then
               rFind.Cells(1, 2).Value = AC.Cells(1, 2).Value
               rFind.Cells(1, 2).Font.ColorIndex = 3        '** oder Interior.Colorindex
               b = b + 1   'Markiert Zähler
            End If
            'bei gleichem Wert in B Spalte C vergleichen
            If AC.Cells(1, 2) = rFind.Cells(1, 2) Then
               If AC.Cells(1, 3) <> rFind.Cells(1, 3) Then
                  rFind.Cells(1, 3).Value = AC.Cells(1, 3).Value
                  rFind.Cells(1, 3).Font.ColorIndex = 3     '** oder Interior.Colorindex
                   c = c + 1   'Markiert Zähler
                End If
            End If
        Else  'Wert wurde nicht gefunden!!
           '(Spalte A-C kopieren, unten anhängen
           AC.Resize(1, 3).Copy Tb2.Cells(lz2, 1)
           lz2 = lz2 + 1:  n = n + 1     'next Zeile
        End If
    Next AC

    If b > 0 Then Txt = b & "  in Spalte B markiert" & vbLf
    If c > 0 Then Txt = Txt & c & "  in Spalte C markiert" & vbLf
    If n > 0 Then Txt = Txt & n & "  neue Werte unten angehangen"
    If b + c + n = 0 Then Txt = "Alle Werte stimmen überein!!"
    
     MsgBox Txt  'Meldung ausgeben
End With
End Sub

 

 

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
18.10.2021 13:26:41 Maximilian Ehrhardt
Solved
Blau Schleifen suche
19.10.2021 10:42:11 Nobody
NotSolved
19.10.2021 14:23:58 Maximilian Ehrhardt
NotSolved
19.10.2021 17:28:23 Gast01287
NotSolved
19.10.2021 20:23:54 Nobody
NotSolved