Thema Datum  Von Nutzer Rating
Antwort
22.01.2016 09:23:28 Stephanie
NotSolved
Blau Hilfe bei VBA Programmierung
23.01.2016 10:14:21 Gast75078
NotSolved
25.01.2016 13:00:41 Stephanie
NotSolved
25.01.2016 19:36:33 Gast96028
Solved
26.01.2016 11:32:23 Gast34823
NotSolved
26.01.2016 12:05:24 Gast75279
Solved
26.01.2016 13:49:09 Gast88431
NotSolved
27.01.2016 00:55:29 Gast78527
Solved
27.01.2016 14:09:32 RainerMU78
NotSolved
27.01.2016 14:26:31 Gast17352
NotSolved
27.01.2016 16:04:46 Stephanie
NotSolved

Ansicht des Beitrags:
Von:
Gast75078
Datum:
23.01.2016 10:14:21
Views:
818
Rating: Antwort:
  Ja
Thema:
Hilfe bei VBA Programmierung

Moin!

HIer mal eine Variante mit ganz viel grün. :-) Das grüne kannst du später auch löschen, da es beim Lesen des eigentlichen COdes nur stört.

Wenn Fragen dazu sind, einfach meldem.

Schönes Wochenende noch.

Option Explicit
 
Sub vergleichen()
'Variablen und Objecte die benötigt werden.
Dim j As Long           'Zähler
Dim eins As Object      ' für das 1.Arbeitsblatt
Dim zwei As Object      ' für das 2.Arbeitsblatt
Dim anzahl As Long      ' Anzahl der Wert
Dim zeile As Long       ' Zeile mit dem Wert in Blatt 2
Dim anders As Long      ' Anzahl der unterschiedlichen Preise des Wertes
Dim ende As Long        ' für die letzte Zeile in Blatt 2

'erstmal Aktualsisierungen des Bildschirms ausschalten
Application.ScreenUpdating = False
 
'um die richtigen Stellen anzusprechen und später nicht immer Worksheets(1) etc. zu schreiben, die Namen anderen Objekten zuweisen
'macht das kürzer und man erkennt noch wo man ist
Set eins = Worksheets(1)        'Objekt auf das Blatt1
Set zwei = Worksheets(2)        'Objekt auf das Blatt2
 
'da im Blatt 2 Unterschiede hervorgehoben werden sollen, erstmal die alten Farben im ganzen Blatt 2 löschen
zwei.UsedRange.Interior.ColorIndex = xlNone

'jetzt beginnt die Prüfung
If eins.Cells(2, 1) <> "" Then
' in Zelle A2 steht nix, dann nix machen (würde in die else Schleife kommen, da dort nix gemacht wird habe ich sie weggelassen).
'Es geht also weiter, wenn was in A2 steht.
 
 
'prüfen, ob der Wert in Blatt 2 schonmal virkokmmt. deshalb einfach die Anzahl zählen lassen. Sollte beim Treffer größer 1 sein. Sonst 0.
anzahl = Application.WorksheetFunction.CountIf(zwei.Columns(1), eins.Cells(2, 1))
    
    If anzahl = 0 Then      ' es wurde kein Wert gefunden, also neu eintragen
        
        'die letzte Zeile in Blatt 2 finden, dort wollen wir ja eintragen
        ende = zwei.Cells(Rows.Count, 1).End(xlUp).Row
        
        'falls die liste noch leer ist, mal prüfen, wo ende genau war. bei 1 auf 3 setzen - später wird beim Code 1 dazugezählt so das beim ersten Eintrag A4 kommen würde
        If ende = 1 Then ende = 3
        'jetzt die Zeile 2 von Blatt eins, ans Ende de Einträge von Blatt 2 kopieren
        ' die Zeile dafür ist ende +1 = letzte beschriebene Zeile + 1 ,
    
        eins.Rows(2).Copy zwei.Rows(ende + 1)
        'die erste Zelle des Eintrags markieren, damit man ihn gleich sieht
        zwei.Cells(ende + 1, 1).Interior.ColorIndex = 6
        'Meldung für den Anwender
        MsgBox "Die Daten waren noch nicht vorhanden. Sie wurden am Ende eingefügt!"
    Else
        'Zähler fpr die Änderungen auf 0
        anders = 0
        'die Zeile mit dem Eintrag suchen
        zeile = Application.WorksheetFunction.Match(eins.Cells(2, 1), zwei.Columns(1), 0)
        'jetzt die Spaöte C bis I vergleichen.
        For j = 3 To 9
                If zwei.Cells(zeile, j) <> eins.Cells(2, j) Then        ' Werte unterscheiden sich
                    zwei.Cells(zeile, j).Interior.ColorIndex = 6        ' Wert markieren
                    anders = anders + 1                                 ' Zähler hochsetzen
                End If
        Next j
        'die erste Zelle des Eintrags markieren, damit man ihn gleich sieht
        zwei.Cells(zeile, 1).Interior.ColorIndex = 6
        ' noch eine NAchricht
        If anders = 0 Then
            MsgBox "Die Daten waren mit den selben Werten vorhanden!"
        Else
            MsgBox "Die Daten waren vorhanden! Es gab allerdings " & anzahl & " unterschiedliche Werte. Diese wurden farbig markiert aber nicht geändert."
        End If
        
    End If
End If

'die Objekte wieder ins nirvana schicken.
Set eins = Nothing
Set zwei = Nothing
 
'und Aktualsisierungen wieder einschalten
Application.ScreenUpdating = True
 
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
22.01.2016 09:23:28 Stephanie
NotSolved
Blau Hilfe bei VBA Programmierung
23.01.2016 10:14:21 Gast75078
NotSolved
25.01.2016 13:00:41 Stephanie
NotSolved
25.01.2016 19:36:33 Gast96028
Solved
26.01.2016 11:32:23 Gast34823
NotSolved
26.01.2016 12:05:24 Gast75279
Solved
26.01.2016 13:49:09 Gast88431
NotSolved
27.01.2016 00:55:29 Gast78527
Solved
27.01.2016 14:09:32 RainerMU78
NotSolved
27.01.2016 14:26:31 Gast17352
NotSolved
27.01.2016 16:04:46 Stephanie
NotSolved