Jeweils zwei Zeilenpaare vergleichen

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

Betrifft: Jeweils zwei Zeilenpaare vergleichen
von: herb roder
Geschrieben am: 30.08.2015 14:43:51

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!

Bild

Betrifft: AW: Jeweils zwei Zeilenpaare vergleichen
von: Hajo_Zi
Geschrieben am: 30.08.2015 15:08:23
Warum VB?
Mache es es mit bedingter Formatierung, mal so laut Beschreibung gesehen.


Bild

Betrifft: AW: Jeweils zwei Zeilenpaare vergleichen
von: herb roder
Geschrieben am: 30.08.2015 16:16:47
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!

Bild

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

Bild

Betrifft: AW: auf offen gestellt
von: Werner
Geschrieben am: 31.08.2015 10:48:57


Bild

Betrifft: AW: Jeweils zwei Zeilenpaare vergleichen
von: Sepp
Geschrieben am: 05.09.2015 15:37:30
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


Bild

Betrifft: Etwas übersichtlicher
von: Sepp
Geschrieben am: 05.09.2015 15:53:42

' **********************************************************************
' 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


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Jeweils zwei Zeilenpaare vergleichen"