Code läuft nicht bei "Mappe freigeben"
07.02.2009 18:49:34
Wolfgang
der untenstehende Code wurde mir aus dem Forum (ich weiß leider nicht mehr, von wem) zur Verfügung gestellt. Er läuft auch grundsätzlich super und ohne Probleme. Nun habe ich aber die Arbeitsmappe im Rahmen der Vernetzung freigegeben und der Code läuft nicht mehr. Gäbe es eine Möglichkeit, den Code irgendwie anzupassen, damit er auch bei Arbeitsmappe freigeben läuft. Gäbe es andernfalls Alternativen? - Erreicht werden soll, dass überprüft werden soll, ob Datensätze in der Tabelle Daten doppelt vorhanden sind. Kriterium sein sollen Spalte C und E; - Danke schon jetzt für die Rückmeldungen.
Gruß - Wolfgang
Sub compareRanges()
Dim objWsA As Worksheet, objWsB As Worksheet
Dim rngA As Range, rngB As Range
Dim strA As String, strB As String, strSheet As String
Dim lngRow As Long, lngIndex As Long
Dim varRes As Variant
Application.ScreenUpdating = False
Sheets("Daten").Select
Columns("I:I").Select
Selection.ClearContents
Do
strSheet = "Daten"
If strSheet = "" Then Exit Sub
If SheetExist(strSheet) Then Exit Do
Loop
Set objWsA = Sheets(strSheet)
Do
strSheet = "Daten"
If strSheet = "" Then Exit Sub
If SheetExist(strSheet) Then Exit Do
Loop
Set objWsB = Sheets(strSheet)
Set rngA = objWsA.Range("C2:E" & Application.Max(objWsA.Cells(Rows.Count, 5).End(xlUp).Row, _
2))
Set rngB = objWsB.Range("C2:E" & Application.Max(objWsB.Cells(Rows.Count, 5).End(xlUp).Row, _
2))
For lngIndex = 1 To rngB.Columns.Count
strB = strB + rngB.Parent.Name & "!" & rngB.Columns(lngIndex).Address & "&"
Next
strB = Left(strB, Len(strB) - 1)
For lngRow = 1 To rngA.Rows.Count
strA = ""
For lngIndex = 1 To rngA.Columns.Count
strA = strA + rngA.Parent.Name & "!" & rngA.Cells(lngRow, lngIndex).Address & "&"
Next
strA = Left(strA, Len(strA) - 1)
If objWsA Is objWsB Then
varRes = Evaluate("SUM(N(" & strB & "=" & strA & "))")
If varRes >= 2 Then
varRes = Evaluate("MATCH(" & strA & "," & strB & ",0)")
Else
varRes = ""
End If
Else
varRes = Evaluate("MATCH(" & strA & "," & strB & ",0)")
End If
If IsNumeric(varRes) Then
rngA.Parent.Hyperlinks.Add _
Anchor:=rngA.Cells(lngRow, rngA.Columns.Count).Offset(0, 4), _
Address:="", _
SubAddress:=rngB.Parent.Name & "!" & rngB.Rows(varRes).Address, _
TextToDisplay:="Datensatz doppelt!"
End If
Next
Set objWsA = Nothing
Set objWsB = Nothing
Set rngA = Nothing
Set rngB = Nothing
Range("A1").Select
Application.ScreenUpdating = True
End Sub