Teilbegriff suchen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Das mache ich natürlich gerne:


Sub Suchen()
Application.ScreenUpdating = False
Dim Wert As Variant, Ort As Variant
Dim Zelle As Variant, Zielblatt As Variant, Quellblatt As Variant
Dim intLastRow As Double, Beginn As Double, Zeile As Double
Zielblatt = "Master Datei"
Quellblatt = "Ausrüstung"
Worksheets(Zielblatt).Select
intLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For Beginn = 4 To intLastRow
Ort = Worksheets(Zielblatt).Cells(Beginn, 1).Value
If Ort  "" Then
For Each c In Worksheets(Quellblatt).Columns(2).Cells
If c.Value Like "*" & Ort & "*" Then
' If InStr(1, c.Value, Ort) > 0 Then
Zeile = c.Row
Wert = Worksheets(Quellblatt).Cells(Zeile, 7).Value
If Wert = 1 Then
Worksheets(Zielblatt).Cells(Beginn, 40).Value = "ja"
Else
Worksheets(Zielblatt).Cells(Beginn, 40).Value = "nein"
Worksheets(Zielblatt).Cells(Beginn, 40).Font.ColorIndex = 3
Worksheets(Zielblatt).Cells(Beginn, 40).Font.Bold = True
End If
End If
Next
End If
Next Beginn
Application.ScreenUpdating = True
End Sub

Die Ortschaft wird vom Zielblatt übernommen und ändert mit der For-Schlaufe.
Gregor

Hi
ich sehe jetzt keinen Grund, warum nicht alle gefunden werden sollen.
Hast du mal ein Beispiel, welcher Ort nicht gefunden wurde (dh. beide Werte, den Eingabewert und den Ort, der gesucht, aber nicht gefunden wurde)
Was mir spontan als Grund einfallen würde, wäre unterschiedliche Gross/Kleinschreibung, das könntest du aber bspw mit


If LCase(c.Value) Like "*" & LCase(Ort) & "*" Then

ausgleichen.
allerdings frage ich mich, ob du die Aufgabe nicht einfach über die SVERWEIS-Funktion und ne bedingte Formatierung lösen könntest, auch beim SVerweis kann man mit den Platzhaltern arbeiten.
Trotzdem musst du dir darüber im klaren sein, daß
wenn du "Locle, Le" mit "Le Locle" suchen willst, auch ein "*Le Locle*" nie zu einem Treffer führen kann, sondern immer nur ein "*Locle*"
Gruß, Daniel

Sub tt() Dim vntQ, vntZ, vntMatch() Dim iQ, iZ, i As Integer With Sheets("Quelle") vntQ = .Range(.Cells(1, 1), .Cells(65536, 1).End(xlUp)) End With With Sheets("Ziel") vntZ = .Range(.Cells(1, 1), .Cells(65536, 1).End(xlUp)) End With ReDim vntMatch(1 To UBound(vntZ)) For iQ = 1 To UBound(vntQ) For iZ = 1 To UBound(vntZ) For i = Len(vntZ(iZ, 1)) To 3 Step -1 If InStr(1, vntQ(iQ, 1), Left(vntZ(iZ, 1), i), vbTextCompare) > 0 Then vntMatch(iZ) = vntQ(iQ, 1) Exit For End If Next Next Next With Sheets("Ziel") .Columns(2).ClearContents .Range(.Cells(1, 2), .Cells(UBound(vntZ), 2)) = WorksheetFunction.Transpose(vntMatch) End With End Sub

Beliebteste Forumthreads (12 Monate)

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread