Hallo Leute,
Habe folgenden Code:
Option Base 1
Option Compare Text
Sub Suchen_und_anzeigen() Dim Meldung As Long Dim Schleife As Byte, y As Byte Dim Suchen() As Variant, SuchenZeile() As Long Dim Bereich As Range Dim n%, x%, yZelle& Dim wksImport As Worksheet Set wksImport = ActiveWorkbook.Worksheets("Import") If ActiveSheet.Name wksImport.Name Then MsgBox "Makro""Suchen_und_anzeigen"" darf nur gestartet " _ & "werden wenn Blatt ""Import"" das aktive Blatt ist!" Exit Sub End If 'gesuchte Kontonummern aus Selektion einlesen und Inhalte in Ergebniszellen löschen Schleife = 0 Application.ScreenUpdating = False With wksImport For Each Bereich In .Range(.Cells(12, 1), .Cells(.Rows.Count, 1).End(xlUp)).Cells 'Prüfen, ob Zelle leer If Bereich "" Then 'prüfen, ob Zellinhalt nummerisch If IsNumeric(Bereich.Value) Then Schleife = Schleife + 1 ReDim Preserve Suchen(1 To Schleife) ReDim Preserve SuchenZeile(1 To Schleife) Suchen(Schleife) = Bereich.Value SuchenZeile(Schleife) = Bereich.Row With wksImport.Cells(Bereich.Row, 6) .ClearContents .Offset(0, 2).ClearContents End With End If End If Next End With ' Eigentlicher Suchvorgang (in allen Tabellenblättern ausßer "Import") x = 1 For y = 1 To Schleife For n = 1 To Sheets.Count If Sheets(n).Name wksImport.Name Then 'Suchbereich festlegen Set Bereich = Worksheets(n).Columns(1) With Bereich Set c = .Find(Suchen(y), after:=Sheets(n).Cells(Sheets(n).Rows.Count, 1), _ LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then ErsteAdresse = c.Address Do With wksImport.Cells(SuchenZeile(y), 6) If .Value = "" Then .Value = Sheets(n).Name .Offset(0, 2).Value = c.Row Else Application.ScreenUpdating = True MsgBox "zu Konto """ & Suchen(y) _ & """ gibt es eine weitere Fundstelle in:" & vbLf _ & Sheets(n).Name & ", Zeile " & c.Row Application.ScreenUpdating = False End If End With Set c = .FindNext(c) x = x + 1 Loop While Not c Is Nothing And c.Address ErsteAdresse End If End With End If Next n Next y Application.ScreenUpdating = True ' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner ' gefunden wurde dann ist x = 1 Select Case x Case 1 Meldung = MsgBox("Es wurde kein übereinstimmender Wert gefunden", _ vbOKOnly, "G E F U N D E N E W E R T E") Exit Sub Case Else Meldung = MsgBox("Es wurden " & (x - 1) & " Übereinstimmungen gefunden.", _ vbOKOnly, "G E F U N D E N E W E R T E") End Select Erase Suchen, SuchenZeile End Sub ------------------------------------------------------------------------------
Jetzt sucht es bei mir nur die Nummerischen Zahlen. Ich möchte das es auch Alphanummerischen Zahlen sucht.
Was muss ich anpassen?
Kann man noch einbauen, wenn die Zelle beim Tabellenblatt "Impot" leer ist, sollte es beim Suchegebnis auch leer sein.
Hier der Link für die Test-Datei:
https://www.herber.de/bbs/user/88035.xls
Vielen Dank für Eure Antworten.
Gruss Tim