Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1444to1448
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Jeweils zwei Zeilenpaare vergleichen

Jeweils zwei Zeilenpaare vergleichen
30.08.2015 14:43:51
herb
Hallo,
vielleicht könnte mir jemand helfen?
Ich bräuchte ein Makro, das folgendes macht: Nach einer Selection sollen jeweils zwei Zeilen, d.h. 1 und 2, 3 und 4 usw. miteinander verglichen werden. Diejenigen Zellen, die in den Zeilenpaaren nicht gleich sind, sollen farbig hervorgehoben werden.
Ich habe eine Beispieldatei angehängt.
https://www.herber.de/bbs/user/99903.xlsx
Vielen Dank im Voraus für Eure Hilfe!

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Jeweils zwei Zeilenpaare vergleichen
30.08.2015 15:08:23
Hajo_Zi
Warum VB?
Mache es es mit bedingter Formatierung, mal so laut Beschreibung gesehen.

AW: Jeweils zwei Zeilenpaare vergleichen
30.08.2015 16:16:47
herb
Hallo Hajo,
ich glaube, das geht nicht, weil es noch Unterstreichungen gibt. Diese Unterstreichungen betreffen sogar teilweise nur Teile des Zellinhalts.
Viele Grüße und Danke fürs Lesen!

AW: Jeweils zwei Zeilenpaare vergleichen
31.08.2015 07:26:35
herb
Niemand?
Sorry, bei mir funktioniert die Aktivierung des Kontrollkästchens scheinbar nicht.

AW: auf offen gestellt
31.08.2015 10:48:57
Werner

AW: Jeweils zwei Zeilenpaare vergleichen
05.09.2015 15:37:30
Sepp
Hallo Herbert,
so?
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub compareText()
Dim rng As Range
Dim lngRow As Long, lngRowCount As Long
Dim lngCol As Long, lngColCount As Long
Dim lngI As Long

Dim bolCompare As Boolean

On Error Resume Next
Set rng = Application.InputBox("Bitte Bereich auswählen", "Vergleichen", Selection.Address, Type:=8)
On Error GoTo 0

If Not rng Is Nothing Then
  lngRowCount = rng.Rows.Count
  lngColCount = rng.Columns.Count
  rng.Interior.ColorIndex = xlNone
  For lngRow = 1 To lngRowCount Step 2
    For lngCol = 1 To lngColCount
      bolCompare = True
      bolCompare = rng.Cells(lngRow, lngCol) = rng.Cells(lngRow + 1, lngCol)
      If bolCompare Then
        For lngI = 1 To Len(rng.Cells(lngRow, lngCol).Text)
          bolCompare = rng.Cells(lngRow, lngCol).Characters(lngI, 1).Font.Bold = _
            rng.Cells(lngRow + 1, lngCol).Characters(lngI, 1).Font.Bold
          If bolCompare Then bolCompare = rng.Cells(lngRow, lngCol).Characters(lngI, 1).Font.Italic = _
            rng.Cells(lngRow + 1, lngCol).Characters(lngI, 1).Font.Italic
          If bolCompare Then bolCompare = rng.Cells(lngRow, lngCol).Characters(lngI, 1).Font.Underline = _
            rng.Cells(lngRow + 1, lngCol).Characters(lngI, 1).Font.Underline
          If bolCompare Then bolCompare = rng.Cells(lngRow, lngCol).Characters(lngI, 1).Font.Superscript = _
            rng.Cells(lngRow + 1, lngCol).Characters(lngI, 1).Font.Superscript
          If bolCompare Then bolCompare = rng.Cells(lngRow, lngCol).Characters(lngI, 1).Font.Subscript = _
            rng.Cells(lngRow + 1, lngCol).Characters(lngI, 1).Font.Subscript
          If bolCompare Then bolCompare = rng.Cells(lngRow, lngCol).Characters(lngI, 1).Font.Strikethrough = _
            rng.Cells(lngRow + 1, lngCol).Characters(lngI, 1).Font.Strikethrough
        Next
      End If
      If Not bolCompare Then rng.Cells(lngRow, lngCol).Resize(2, 1).Interior.ColorIndex = 3
    Next
  Next
End If

Set rng = Nothing
End Sub


Gruß Sepp

Anzeige
Etwas übersichtlicher
05.09.2015 15:53:42
Sepp
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub compareText()
Dim rng As Range, rngA As Range, rngB As Range
Dim lngRow As Long, lngRowCount As Long
Dim lngCol As Long, lngColCount As Long
Dim lngI As Long

Dim bolCompare As Boolean

On Error Resume Next
Set rng = Application.InputBox("Bitte Bereich auswählen", "Vergleichen", Selection.Address, Type:=8)
On Error GoTo 0

If Not rng Is Nothing Then
  lngRowCount = rng.Rows.Count
  lngColCount = rng.Columns.Count
  rng.Interior.ColorIndex = xlNone
  For lngRow = 1 To lngRowCount Step 2
    For lngCol = 1 To lngColCount
      bolCompare = True
      Set rngA = rng.Cells(lngRow, lngCol)
      Set rngB = rngA.Offset(1, 0)
      bolCompare = rngA = rngB
      If bolCompare Then
        For lngI = 1 To Len(rngA.Text)
          With rngA.Characters(lngI, 1).Font
            bolCompare = .Bold = rngB.Characters(lngI, 1).Font.Bold
            If bolCompare Then bolCompare = .Italic = rngB.Characters(lngI, 1).Font.Italic
            If bolCompare Then bolCompare = .Underline = rngB.Characters(lngI, 1).Font.Underline
            If bolCompare Then bolCompare = .Superscript = rngB.Characters(lngI, 1).Font.Superscript
            If bolCompare Then bolCompare = .Subscript = rngB.Characters(lngI, 1).Font.Subscript
            If bolCompare Then bolCompare = .Strikethrough = rngB.Characters(lngI, 1).Font.Strikethrough
            If Not bolCompare Then Exit For
          End With
        Next
      End If
      If Not bolCompare Then rngA.Resize(2, 1).Interior.ColorIndex = 3
    Next
  Next
End If

Set rng = Nothing
Set rngA = Nothing
Set rngB = Nothing
End Sub


Gruß Sepp

Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige