Forumbeitrag
Excel-Version des Fragestellers:
2019
Erfahrungslevel des Fragestellers:
VBA nur mit Recorder
Hi Sabrina,
da du sowieso VBA verwendest, lies die Zellen in ein Array, dann kannst du die Suche voll beeinflussen. Solange due keine Fantastilliarden an Zellen vererbeitest geht das flott genug.
In deiner Datei getestet und tut
Option 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 Sub
hth
Ulf