Spalten vergleichen und doppelte markieren

parza · 2017-10-08T11:32:49+00:00

Halllo zusammen, vor einiger Zeit hat mir das Forum sehr hilfreich bei der unten stehen Programmierung super geholfen. Ziel ist, dass alle Daten in einer Datei, die aus mehreren Registerkarten besteht, jeweils in Spalte "M" (also 13) miteinander verglichen und doppelte Daten rot markiert werden sollen. Nun zum Problem: Da sich die Datei geändert hat, zwei Spalten weniger, war die ursprüngliche Programmierung auf "O" (15) ausgelegt und hat wunderbar funktioniert. Habe ich beim Ändern auf "M" und die 13 eventuell irgendetwas übersehen? Bin Programmierlaie. Vielen Dank, parza Nun der Code: Dim strVergleich As String Dim intActiveSheet As Integer Dim intAnzahl As Integer Dim lngLast As Long Dim i As Long Dim x As Long Application.ScreenUpdating = False Application.EnableEvents = False 'Vergleichen und farbig stellen With ThisWorkbook For intAnzahl = 1 To .Worksheets.Count lngLast = .Worksheets(intAnzahl).Cells(Rows.Count, 13).End(xlUp).Row For intActiveSheet = 1 To .Worksheets.Count If intActiveSheet intAnzahl Then For i = 1 To lngLast If .Worksheets(intAnzahl).Cells(i, 13).Value "" Then strVergleich = .Worksheets(intAnzahl).Cells(i, 13).Value For x = 1 To Worksheets(intActiveSheet).Cells(Rows.Count, 13).End(xlUp).Row If strVergleich = Worksheets(intActiveSheet).Range("M" & x).Value Then .Worksheets(intAnzahl).Cells(i, 13).Font.Color = vbRed GoTo ENDE End If Next x End If ENDE: Next i End If Next intActiveSheet Next intAnzahl End With Application.EnableEvents = True Application.ScreenUpdating = True End Sub

Hallo parza,
ohne jetzt auf den anderen Code einzugehen, würde ich es so lösen.

' **********************************************************************
' Modul: Modul2  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub vergleich()
Dim objWS As Worksheet, objAllWS As Worksheet
Dim objColor As Range, objFind As Range, objValue As Range, objCell As Range

Const lngColumn As Long = 13

On Error GoTo ErrorHandler

For Each objAllWS In ThisWorkbook.Worksheets
  Set objValue = objAllWS.Columns(lngColumn).SpecialCells(xlCellTypeConstants)
  For Each objWS In ThisWorkbook.Worksheets
    If Not objWS Is objAllWS Then
      Set objColor = Nothing
      For Each objCell In objValue
        Set objFind = objWS.Columns(lngColumn).Find(what:=objCell.Value, LookIn:=xlValues, _
          Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not objFind Is Nothing Then
          If objColor Is Nothing Then
            Set objColor = objFind
          Else
            Set objColor = Union(objColor, objFind)
          End If
        End If
      Next
      If Not objColor Is Nothing Then objColor.Font.Color = vbRed
    End If
  Next
Next

ErrorHandler:

If Err.Number <> 0 Then
  MsgBox "Fehler in Modul2" & vbLf & vbLf & "Prozedur:" & vbTab & "vergleich" & vbLf & _
    "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
    IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
  Err.Clear
End If

Set objAllWS = Nothing
Set objWS = Nothing
Set objColor = Nothing
Set objCell = Nothing
Set objValue = Nothing
Set objFind = Nothing
End Sub

Gruß Sepp

Hallo Parza,
die Meldung kommt, wenn in einer Tabelle die Spalte 13 leer ist.
So kommt keine Meldung.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub vergleich()
Dim objWS As Worksheet, objAllWS As Worksheet
Dim objColor As Range, objFind As Range, objValue As Range, objCell As Range

Const lngColumn As Long = 13  'Vergleichsspalte!

On Error GoTo ErrorHandler

For Each objAllWS In ThisWorkbook.Worksheets
  Set objValue = Nothing
  On Error Resume Next
  Set objValue = objAllWS.Columns(lngColumn).SpecialCells(xlCellTypeConstants)
  Err.Clear
  On Error GoTo ErrorHandler
  If Not objValue Is Nothing Then
    For Each objWS In ThisWorkbook.Worksheets
      If Not objWS Is objAllWS Then
        Set objColor = Nothing
        For Each objCell In objValue
          Set objFind = objWS.Columns(lngColumn).Find(what:=objCell.Value, LookIn:=xlValues, _
            Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
          If Not objFind Is Nothing Then
            If objColor Is Nothing Then
              Set objColor = objFind
            Else
              Set objColor = Union(objColor, objFind)
            End If
          End If
        Next
        If Not objColor Is Nothing Then objColor.Font.Color = vbRed
      End If
    Next
  End If
Next

ErrorHandler:

If Err.Number <> 0 Then
  MsgBox "Fehler in Modul2" & vbLf & vbLf & "Prozedur:" & vbTab & "vergleich" & vbLf & _
    "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
    IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
  Err.Clear
End If

Set objAllWS = Nothing
Set objWS = Nothing
Set objColor = Nothing
Set objCell = Nothing
Set objValue = Nothing
Set objFind = Nothing
End Sub

Gruß Sepp

Spalten vergleichen und doppelte markieren

Forumthread: Spalten vergleichen und doppelte markieren

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Doppelte Werte in zwei Spalten markieren mit Excel

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)

Spalten vergleichen und doppelte markieren

Forumthread: Spalten vergleichen und doppelte markieren

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Infobox / Tutorial

Doppelte Werte in zwei Spalten markieren mit Excel

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread