Spalten vergleichen und doppelte markieren

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Sub LP_Beamte() Const Pfad As String = "F:\LP-Beamte\2017\" 'Abschließender Backslash!!! Dim DatNam As String, DatExt As String '2. Eine Message Box öffnet sich in der gefragt wird ob wirklich gespeichert werden soll. _ Antwort Yes or No DatNam = ThisWorkbook.Name 'Dateiname (ohne Pfad) DatExt = Mid(DatNam, InStrRev(DatNam, ".")) 'Dateinamenerweiterung ( _ mit Punkt) DatNam = Mid(DatNam, 1, InStrRev(DatNam, ".") - 1) 'Dateiname (ohne Pfad, _ ohne Erweiterung) DatNam = DatNam & Format(Now, "_DD.MM.YY_hh-mm") & DatExt 'neuer Dateiname If MsgBox("Soll eine Kopie der Datei" & vbLf & ThisWorkbook.Name & vbLf & "unter" & vbLf & _ _ Pfad & DatNam & vbLf & "abgelegt werden", vbYesNo) = vbYes Then '3. Bei Yes: Die Datei wird mit dem akuellen Dateinamen plus Datum _ und Uhrzeit in den angegebenen Ordner gespeichert. ThisWorkbook.SaveCopyAs Pfad & DatNam End If '4. Bei No: Abbruch '5. ENDE End Sub

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

Beliebteste Forumthreads (12 Monate)

Spalten vergleichen und doppelte markieren

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

318 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Spalten vergleichen und doppelte markieren

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

318 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread