Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' On Error Resume Next
Dim wks As Worksheet
Dim rngIntersect As Range
Dim rngArea As Range
Dim vntItem As Variant
Dim blnExist As Boolean
Dim lngCount As Long
Const conDetectionRangeAddress As String = "A2:A50"
With Target
Set rngIntersect = Intersect(Target, Sh.Range(conDetectionRangeAddress))
If Not rngIntersect Is Nothing Then
For Each wks In Me.Worksheets
lngCount = Abs(wks Is Sh)
For Each rngArea In rngIntersect.Areas
If rngArea.Cells.Count = 1 Then
vntItem = rngArea.Value
blnExist = (WorksheetFunction.CountIf(wks.Range(conDetectionRangeAddress), vntItem) > lngCount)
Else
For Each vntItem In rngArea.Value
blnExist = (WorksheetFunction.CountIf(wks.Range(conDetectionRangeAddress), vntItem) > lngCount)
If blnExist Then: Exit For
Next
End If
If blnExist Then Exit For
Next
If blnExist Then Exit For
Next
If blnExist Then
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "Lfd. Nr. " & vntItem & " ist bereits in " & wks.Name & vbNewLine & "in Zelle " & wks.Range(conDetectionRangeAddress).Find(vntItem, , xlValues).Address(0, 0) & " vorhanden!", _
vbExclamation, "A C H T U N G"
End If
End If
End With
Set wks = Nothing
Set rngArea = Nothing
Set rngIntersect = Nothing
End Subdim vntFundstelle as variant
vntFundstelle = Application.Match(vntItem, wks.Range(conDetectionRangeAddress), 0)
if not IsError(vntFundstelle) Then Msgbox "Gefunden in Zeile " & vntFundstelleOption Explicit
Dim wb As Workbook
Dim wks As Worksheet
Dim rg As Range
Dim lngTabelle As Long
Dim lngTabellen As Long
Dim lngZähler As Long
Dim lngZeilen As Long
Dim arrZellen '(9, 49)
Dim strRange As String '
Dim bGelesen As Boolean
Private Sub Workbook_Open()
bGelesen = leseZellen()
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim strRg As String
Dim strTabelle As String
strTabelle = CStr(Sh.Name)
strRg = CStr(Target.Address)
If bGelesen Then
If Target.Cells.Count = 1 Then
For lngTabelle = 0 To lngTabellen - 1
For lngZähler = 0 To lngZeilen
If Target.Value = arrZellen(lngTabelle, lngZähler) Then
Set wks = ThisWorkbook.Worksheets(lngTabelle + 1)
Set rg = wks.Range(strRange).Cells(lngZähler + 1)
MsgBox "Der Wert " & Target.Value & " steht schon in " & wks.Name & " in Zelle " & rg.Address
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Exit Sub
End If
Next lngZähler
Next lngTabelle
Else
'Bei Arrays muss zuerst dass Array selbst auf Duplikate untersucht werden
'bspw for each zelle in Target.cells ...
'
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
End Sub
Public Function leseZellen() As Boolean
On Error GoTo leseZellenERR
Dim bRet As Boolean
Set wb = ThisWorkbook
'ANPASSEN
lngTabellen = wb.Worksheets.Count
lngZeilen = 100
'ANPASSEN
strRange = "A11:A" & (11 + lngZeilen)
ReDim arrZellen(lngTabellen, lngZeilen)
For lngTabelle = 1 To lngTabellen '10
Set wks = wb.Worksheets(lngTabelle)
Set rg = wks.Range(strRange)
For lngZähler = 1 To 49
arrZellen(lngTabelle - 1, lngZähler - 1) = rg.Cells(lngZähler)
Next lngZähler
Next lngTabelle
leseZellen = True
leseZellenOUT:
Exit Function
leseZellenERR:
leseZellen = False
Resume leseZellenOUT
End Function
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
bGelesen = leseZellen()
End SubOption Explicit
Dim wb As Workbook
Dim wks As Worksheet
Dim rg As Range
Dim lngTabelle As Long
Dim lngTabellen As Long
Dim lngZähler As Long
Dim lngZeilen As Long
Dim arrZellen '(9, 49)
Dim strRange As String '
Dim bGelesen As Boolean
Private Sub Workbook_Open()
bGelesen = leseZellen()
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim strRg As String
Dim strTabelle As String
strTabelle = CStr(Sh.Name)
strRg = CStr(Target.Address)
If bGelesen Then
If Target.Cells.Count = 1 Then
For lngTabelle = 0 To lngTabellen - 1
For lngZähler = 0 To lngZeilen
If Target.Value = arrZellen(lngTabelle, lngZähler) Then
Set wks = ThisWorkbook.Worksheets(lngTabelle + 1)
Set rg = wks.Range(strRange).Cells(lngZähler + 1)
MsgBox "Der Wert " & Target.Value & " steht schon in " & wks.Name & " in Zelle " & rg.Address
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Exit Sub
End If
Next lngZähler
Next lngTabelle
Else
'Bei Arrays muss zuerst dass Array selbst auf Duplikate untersucht werden
'bspw for each zelle in Target.cells ...
'
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
End Sub
Public Function leseZellen() As Boolean
On Error GoTo leseZellenERR
Dim bRet As Boolean
Set wb = ThisWorkbook
'ANPASSEN
lngTabellen = wb.Worksheets.Count
lngZeilen = 100
'ANPASSEN
strRange = "A11:A" & (11 + lngZeilen)
ReDim arrZellen(lngTabellen, lngZeilen)
For lngTabelle = 1 To lngTabellen '10
Set wks = wb.Worksheets(lngTabelle)
Set rg = wks.Range(strRange)
For lngZähler = 1 To lngZeilen
arrZellen(lngTabelle - 1, lngZähler - 1) = rg.Cells(lngZähler)
Next lngZähler
Next lngTabelle
leseZellen = True
leseZellenOUT:
Exit Function
leseZellenERR:
leseZellen = False
Resume leseZellenOUT
End Function
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
bGelesen = leseZellen()
End SubMsgBox "Lfd. Nr. " & vntItem & " ist bereits in " & wks.Name & vbNewLine & "in A" & Application.Match(vntItem, wks.Range(conDetectionRangeAddress), 0) + 9 & " vorhanden!", vbExclamation, "A C H T U N G"Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wksSheet As Worksheet
Dim blnTMP As Boolean
Dim rngRange As Range
Dim varTMP As Variant
On Error GoTo Fin
Set Target = Intersect(Target, Sh.Range("A10:A200"))
If Not Target Is Nothing Then
Application.EnableEvents = False
For Each rngRange In Target
If rngRange <> "" Then
For Each wksSheet In Worksheets
varTMP = Application.Match(rngRange.Value, wksSheet.Range("A10:A" & wksSheet.Cells(Rows.Count, 1).End(xlUp).Row), 0)
If Not IsError(varTMP) Then
If wksSheet.Name <> Sh.Name Or varTMP + 9 <> rngRange.Row Then
MsgBox "Lfd. Nr. " & rngRange.Value & " schon vorhanden in '" & wksSheet.Name & "' A" & varTMP + 9, vbExclamation
Application.Undo
blnTMP = True
Exit For
End If
End If
Next wksSheet
End If
If blnTMP Then Exit For
Next rngRange
End If
Fin:
Application.EnableEvents = True
End SubPrivate Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("A10:A50")) Is Nothing Then
For Each it In Sheets
For Each it1 In it.Range("A10:A50").SpecialCells(2, 1)
If Target.Value = it1.Value And Target.Address(, , , True) <> it1.Address(, , , True) Then MsgBox "double in " & it1.Address(, , , True), , Target.Address(, , , True)
Next
Next
End If
End Sub
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Wks As Worksheet, Z As Range, tmp
If Not Intersect(Target, Range("A10:A10000")) Is Nothing Then
If Target.Text = "" Then Exit Sub
Application.EnableEvents = False
If IsNumeric(Target.Value) Then Target = CDbl(Target.Value)
For Each Wks In Sheets
For Each Z In Wks.Range("A10:A10000").SpecialCells(xlCellTypeConstants)
If Not IsError(Application.Match(Target, Z.Columns(1), 0)) And Z.Parent.Name <> Target.Parent.Name Then
tmp = Split(Right(Z.Address(0, 0, , True), Len(Z.Address(0, 0, , True)) - InStrRev(Z.Address(0, 0, , True), "]")), "!")
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & tmp(1) & " im Blatt: " & tmp(0) & " enthalten."
Target = ""
Else
If WorksheetFunction.CountIf(Wks.Columns(1), Target) > 1 Then
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & Wks.Cells(Application.Match(Target, Wks.Columns(1), 0), 1).Address(0, 0) & " im Blatt: " & Target.Parent.Name & " enthalten."
Target = ""
End If
End If
Next
Next
End If
Application.EnableEvents = True
End Sub
Option Explicit
Const extMapPath As String = "C:\Berlin\Test_Otto.xlsm"
Const extSh As String = "Test"
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'Alwin Weisangler klappt super
Dim Wks As Worksheet, Z As Range, tmp
If Not Intersect(Target, Range("A10:A10000")) Is Nothing Then
If Target.Text = "" Then Exit Sub
Application.EnableEvents = False
If IsNumeric(Target.Value) Then Target = CDbl(Target.Value)
For Each Wks In Sheets
For Each Z In Wks.Range("A10:A10000").SpecialCells(xlCellTypeConstants)
If Not IsError(Application.Match(Target, Z.Columns(1), 0)) And Z.Parent.Name <> Target.Parent.Name Then
tmp = Split(Right(Z.Address(0, 0, , True), Len(Z.Address(0, 0, , True)) - InStrRev(Z.Address(0, 0, , True), "]")), "!")
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & vbNewLine & tmp(1) & " " & tmp(0) & " enthalten!", vbExclamation, "A C H T U N G"
Target = ""
Target.Select
Else
If WorksheetFunction.CountIf(Wks.Columns(1), Target) > 1 Then
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & vbNewLine & Wks.Cells(Application.Match(Target, Wks.Columns(1), 0), 1).Address(0, 0) & " " & Target.Parent.Name & " enthalten!", vbExclamation, "A C H T U N G"
Target = ""
Target.Select
End If
End If
Next
Next
End If
Application.EnableEvents = True
Call AbgleichExtern(Target)
End Sub
Sub AbgleichExtern(lfdNr As Variant)
Dim rs As Object, arr, i&, k&, datN
Set rs = CreateObject("ADODB.Recordset")
With rs
.CursorLocation = 3
.CursorType = 3
.Open "SELECT * FROM [" & extSh & "$]", "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0 xml"";" & "Data Source= " & extMapPath
If (.EOF And .BOF) = False Then
arr = .GetRows
End If
.Close
End With
Set rs = Nothing
For i = LBound(arr, 2) To UBound(arr, 2)
If IsNumeric(arr(2, i)) Then arr(2, i) = CDbl(arr(2, i))
If arr(2, i) = lfdNr Then k = k + 1
Next i
datN = Right(extMapPath, Len(extMapPath) - InStrRev(extMapPath, "\"))
If k = 0 Then MsgBox "Lfd. Nummer " & lfdNr & " ist nicht in Datei: " & datN & "! vorhanden", vbOKOnly, "Fehler!!!"
End Sub
If k > 0 Then MsgBox "Lfd. Nummer " & lfdNr & " ist in Datei: " & datN & "! vorhanden", vbOKOnly, "Hinweis"
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Wks As Worksheet, Z As Range, tmp, vTar ' vTar für den Fall das Target früh gelesen werden soll
If Not Intersect(Target, Range("A10:A10000")) Is Nothing Then
If Target.Text = "" Then Exit Sub
Application.EnableEvents = False
vTar = Target ' frühes Übergeben des Target.Value
If IsNumeric(Target.Value) Then Target = CDbl(Target.Value)
For Each Wks In Sheets
For Each Z In Wks.Range("A10:A10000").SpecialCells(xlCellTypeConstants)
If Not IsError(Application.Match(Target, Z.Columns(1), 0)) And Z.Parent.Name <> Target.Parent.Name Then
tmp = Split(Right(Z.Address(0, 0, , True), Len(Z.Address(0, 0, , True)) - InStrRev(Z.Address(0, 0, , True), "]")), "!")
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & vbNewLine & tmp(1) & " " & tmp(0) & " enthalten!", vbExclamation, "A C H T U N G"
Target = ""
Target.Select
Else
If WorksheetFunction.CountIf(Wks.Columns(1), Target) > 1 Then
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & vbNewLine & Wks.Cells(Application.Match(Target, Wks.Columns(1), 0), 1).Address(0, 0) & " " & Target.Parent.Name & " enthalten!", vbExclamation, "A C H T U N G"
Target = ""
Target.Select
End If
End If
Next
Next
End If
Application.EnableEvents = True
Call AbgleichExtern(vTar) 'für den Fall das Target spät gelesen werden soll dann: Call AbgleichExtern(Target)
End Sub
Sub AbgleichExtern(lfdNr As Variant)
Dim rs As Object, arr, i&, k&, datN
Set rs = CreateObject("ADODB.Recordset")
With rs
.CursorLocation = 3
.CursorType = 3
.Open "SELECT * FROM [" & extSh & "$]", "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0 xml"";" & "Data Source= " & extMapPath
If (.EOF And .BOF) = False Then
arr = .GetRows
End If
.Close
End With
Set rs = Nothing
For i = LBound(arr, 2) To UBound(arr, 2)
If IsNumeric(arr(2, i)) Then arr(2, i) = CDbl(arr(2, i))
If arr(2, i) = lfdNr Then k = k + 1
Next i
datN = Right(extMapPath, Len(extMapPath) - InStrRev(extMapPath, "\"))
If k = 0 Then MsgBox "Lfd. Nummer " & lfdNr & " ist in Datei: " & datN & "! vorhanden", vbOKOnly, "Fehler!!!"
End Sub
For Each Z In Wks.Range("A10:A10000").SpecialCells(xlCellTypeConstants)
For Each Z In Wks.Range("A10:A" & Wks.Cells(Rows.Count, 1).End(xlUp).Row)
Sub EventEinschalten()
Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Wks As Worksheet, Z As Range, tmp, vTar As Range ' vTar für den Fall das Target früh gelesen werden soll
If Not Intersect(Target, Range("A10:A10000")) Is Nothing Then
If Target.Text = "" Then Exit Sub
Application.EnableEvents = False
Set vTar = Target ' frühes Übergeben des Target.Value
If IsNumeric(Target.Value) Then Target = CDbl(Target.Value)
For Each Wks In Sheets
For Each Z In Wks.Range("A10:A" & Wks.Cells(Rows.Count, 1).End(xlUp).Row)
If Not IsError(Application.Match(Target, Z.Columns(1), 0)) And Z.Parent.Name <> Target.Parent.Name Then
tmp = Split(Right(Z.Address(0, 0, , True), Len(Z.Address(0, 0, , True)) - InStrRev(Z.Address(0, 0, , True), "]")), "!")
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & vbNewLine & tmp(1) & " " & tmp(0) & " enthalten!", vbExclamation, "A C H T U N G"
Target = ""
Target.Select
Else
If WorksheetFunction.CountIf(Wks.Columns(1), Target) > 1 Then
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & vbNewLine & Wks.Cells(Application.Match(Target, Wks.Columns(1), 0), 1).Address(0, 0) & " " & Target.Parent.Name & " enthalten!", vbExclamation, "A C H T U N G"
Target = ""
Target.Select
End If
End If
Next
Next
End If
Application.EnableEvents = True
Call AbgleichExtern(vTar) 'für den Fall das Target spät gelesen werden soll dann: Call AbgleichExtern(Target)
End Sub
Sub AbgleichExtern(lfdNr As Range)
Dim rs As Object, arr, i&, k&, datN
Set rs = CreateObject("ADODB.Recordset")
With rs
.CursorLocation = 3
.CursorType = 3
.Open "SELECT * FROM [" & extSh & "$]", "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0 xml"";" & "Data Source= " & extMapPath
If (.EOF And .BOF) = False Then
arr = .GetRows
End If
.Close
End With
Set rs = Nothing
For i = LBound(arr, 2) To UBound(arr, 2)
If IsNumeric(arr(2, i)) Then arr(2, i) = CDbl(arr(2, i))
If arr(2, i) = lfdNr.Value Then k = k + 1
Next i
datN = Right(extMapPath, Len(extMapPath) - InStrRev(extMapPath, "\"))
If k = 0 Then
MsgBox "Lfd. Nummer " & lfdNr.Value & " ist nicht in Datei: " & datN & "! vorhanden", vbOKOnly, "Fehler!!!"
Application.EnableEvents = False
lfdNr = ""
lfdNr.Activate
Application.EnableEvents = True
End If
End Sub
Option Explicit
Const extMapPath As String = "C:\Berlin\Test_Otto.xlsm"
Const extSh As String = "Test"
Private Sperre As Boolean
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Wks As Worksheet, Z As Range, tmp, vTar As Range ' vTar für den Fall das Target früh gelesen werden soll
If Not Intersect(Target, Range("A10:A10000")) Is Nothing Then
If Target.Text = "" Then Exit Sub
Application.EnableEvents = False
Set vTar = Target ' frühes Übergeben des Target.Value
If IsNumeric(Target.Value) Then Target = CDbl(Target.Value)
For Each Wks In Sheets
For Each Z In Wks.Range("A10:A" & Wks.Cells(Rows.Count, 1).End(xlUp).Row)
If Not IsError(Application.Match(Target, Z.Columns(1), 0)) And Z.Parent.Name <> Target.Parent.Name Then
tmp = Split(Right(Z.Address(0, 0, , True), Len(Z.Address(0, 0, , True)) - InStrRev(Z.Address(0, 0, , True), "]")), "!")
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & vbNewLine & tmp(1) & " " & tmp(0) & " enthalten!", vbExclamation, "A C H T U N G"
Target = ""
Target.Select
Sperre = True
Else
If WorksheetFunction.CountIf(Wks.Columns(1), Target) > 1 Then
MsgBox "Die Lfd. Nr. " & Target & " ist bereits in Zelle: " & vbNewLine & Wks.Cells(Application.Match(Target, Wks.Columns(1), 0), 1).Address(0, 0) & " " & Target.Parent.Name & " enthalten!", vbExclamation, "A C H T U N G"
Target = ""
Target.Select
End If
End If
Next
Next
End If
Application.EnableEvents = True
Call AbgleichExtern(vTar) 'für den Fall das Target spät gelesen werden soll dann: Call AbgleichExtern(Target)
End Sub
Sub AbgleichExtern(lfdNr As Range)
Dim rs As Object, arr, i&, k&, datN
Set rs = CreateObject("ADODB.Recordset")
With rs
.CursorLocation = 3
.CursorType = 3
.Open "SELECT * FROM [" & extSh & "$]", "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0 xml"";" & "Data Source= " & extMapPath
If (.EOF And .BOF) = False Then
arr = .GetRows
End If
.Close
End With
Set rs = Nothing
For i = LBound(arr, 2) To UBound(arr, 2)
If IsNumeric(arr(2, i)) Then arr(2, i) = CDbl(arr(2, i))
If arr(2, i) = lfdNr.Value Then k = k + 1
Next i
datN = Right(extMapPath, Len(extMapPath) - InStrRev(extMapPath, "\"))
If k = 0 Then
If Sperre = False Then MsgBox "Lfd. Nummer " & lfdNr.Value & " ist nicht in Datei: " & datN & "! vorhanden", vbOKOnly, "Fehler!!!"
Sperre = False
Application.EnableEvents = False
lfdNr = ""
lfdNr.Activate
Application.EnableEvents = True
End If
End Sub
Option Explicit
Const strPath As String = "C:\Temp\"
Const strFile As String = "Test_Otto.xlsm"
Const strSheet As String = "Test"
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wksSheet As Worksheet
Dim varMatch As Variant
Dim lngNr As Long
On Error GoTo Fin
If Not Intersect(Target, Sh.Range("A10:A1000")) Is Nothing Or Not Target.CountLarge > 1 Or Not Target = "" Then
Application.EnableEvents = False
lngNr = Target.Value
For Each wksSheet In Worksheets
varMatch = Application.Match(Target.Value, wksSheet.Range("A10:A10000"), 0)
If Not IsError(varMatch) Then
If wksSheet.Name <> Sh.Name Or varMatch + 9 <> Target.Row Then
MsgBox "Lfd. Nr. " & Target & " bereits vorhanden in " & wksSheet.Name & " A" & varMatch + 9, vbExclamation
Target = ""
Target.Select
Exit For
End If
End If
Next wksSheet
If IsError(ExecuteExcel4Macro("MATCH(" & lngNr & ",'" & strPath & "[" & strFile & "]" & strSheet & "'!R9C3:R2000C3,0)")) Then
MsgBox "Nummer " & lngNr & " in " & strFile & " nicht vorhanden!"
Target = ""
Target.Select
End If
End If
Fin:
Application.EnableEvents = True
End SubOption Explicit
Const strPath As String = "C:\Temp\"
Const strFile As String = "180621.xlsm"
Const strSheet As String = "Test"
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim blnDoppelt As Boolean
Dim wksSheet As Worksheet
Dim varMatch As Variant
Dim lngNr As Long
On Error GoTo Fin
If Not Intersect(Target, Sh.Range("A10:A1000")) Is Nothing Or Not Target.CountLarge > 1 Or Not Target = "" Then
Application.EnableEvents = False
lngNr = Target.Value
For Each wksSheet In Worksheets
varMatch = Application.Match(Target.Value, wksSheet.Range("A10:A10000"), 0)
If Not IsError(varMatch) Then
If wksSheet.Name <> Sh.Name Or varMatch + 9 <> Target.Row Then
MsgBox "Lfd. Nr. " & Target & " bereits vorhanden in " & wksSheet.Name & " A" & varMatch + 9, vbExclamation
Target = ""
Target.Select
blnDoppelt = True
Exit For
End If
End If
Next wksSheet
If blnDoppelt Then
If IsError(ExecuteExcel4Macro("MATCH(" & lngNr & ",'" & strPath & "[" & strFile & "]" & strSheet & "'!R9C3:R2000C3,0)")) Then MsgBox "Nummer " & lngNr & " in " & strFile & " nicht vorhanden!"
End If
End If
Fin:
Application.EnableEvents = True
End SubOption Explicit
Const strPath As String = "C:\Temp\"
Const strFile As String = "Test_Otto.xlsm"
Const strSheet As String = "Test"
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wksSheet As Worksheet
Dim varMatch As Variant
Dim lngNr As Long
On Error GoTo Fin
If Not Intersect(Target, Sh.Range("A10:A1000")) Is Nothing Or Not Target.CountLarge > 1 Or Not Target = "" Then
Application.EnableEvents = False
lngNr = Target.Value
For Each wksSheet In Worksheets
varMatch = Application.Match(Target.Value, wksSheet.Range("A10:A10000"), 0)
If Not IsError(varMatch) Then
If wksSheet.Name <> Sh.Name Or varMatch + 9 <> Target.Row Then
MsgBox "Lfd. Nr. " & Target & " bereits vorhanden in " & wksSheet.Name & " A" & varMatch + 9, vbExclamation
Target = ""
Target.Select
Exit For
End If
End If
Next wksSheet
If IsError(ExecuteExcel4Macro("MATCH(" & lngNr & ",'" & strPath & "[" & strFile & "]" & strSheet & "'!R9C3:R2000C3,0)")) Then MsgBox "Nummer " & lngNr & " in " & strFile & " nicht vorhanden!"
End If
Fin:
Application.EnableEvents = True
End Sub