AW: Makro msg für doppelte Einträge
10.05.2016 13:14:47
ChrisL
Hi
Viel Spass...
Sub TestMe()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim arSheet() As Variant
Dim iBlatt As Integer, iZeile As Long
Dim tempCounter As Long, tempAnzahl As Long
Dim tempError As String, sError As String
Dim bError As Boolean, bDoppelt As Boolean
Set WS1 = Worksheets("Tabelle1")
arSheet = Array("Tabelle2", "Tabelle3", "Tabelle4", "Tabelle5", "Tabelle6")
For iZeile = 1 To WS1.Cells(WS1.Rows.Count, 1).End(xlUp).Row
tempCounter = 0
tempError = ""
bDoppelt = False
For iBlatt = 0 To UBound(arSheet)
Set WS2 = Worksheets(arSheet(iBlatt))
tempAnzahl = WorksheetFunction.CountIf(WS2.Columns(1), WS1.Cells(iZeile, 1))
If tempAnzahl > 1 Then
tempError = "Wert '" & WS1.Cells(iZeile, 1) & "' ist auf dem Blatt '" & _
WS2.Name & "' doppelt vorhanden."
bDoppelt = True
Exit For
End If
If tempAnzahl = 1 Then
If tempError = "" Then
tempError = "'" & WS2.Name & "'"
Else
tempError = tempError & " und '" & WS2.Name & "'"
End If
tempCounter = tempCounter + 1
End If
Next iBlatt
If bDoppelt Then
sError = sError & Chr(10) & tempError
bError = True
Else
If tempCounter = 0 Then
sError = sError & Chr(10) & "Wert '" & WS1.Cells(iZeile, 1) & "' in Zeile " _
& iZeile & " fehlt."
bError = True
End If
If tempCounter > 1 Then
sError = sError & Chr(10) & "Wert '" & WS1.Cells(iZeile, 1) & "' in Zeile " _
& iZeile & " kommt mehrfach in Blatt " & tempError & " vor."
bError = True
End If
End If
Next iZeile
If bError Then
MsgBox "Folgende Fehler sind aufgetreten:" & sError
Else
MsgBox "Alles OK."
End If
End Sub
cu
Chris