Probleme mit .Find Methode
15.08.2017 23:14:27
Heiko
Folgendes Problem:
Es gibt 2 Workbooks: in wb2 wird nach Einträgen/ Instrumenten mit ClosingDate im aktuellen Monat gesucht. Sind diese identifiziert, wird über Suchbegriff = .Offset(k, -3).Value - eine Verbindung zu wb1 aufgebaut. Dort taucht der Suchbegriff irgendwo in Spalte B auf.
Die Aufgabe besteht darin den entsprechenden Suchbegriff in wb1 zu finden, und dann die gesamte betroffene Zeile mit Daten über quasi CutCopyPaste an den unteren Rand der Tabelle zu befördern.
Der Code funktioniert für die ersten "5 Treffer" (= übereinstimmende ClosingDate und übereinstimmender Suchbegriff) und wird wie gewollt ausgeführt.
Jedoch kommt es jetzt zum Problem, da bei einem/mehreren Datensätzen übereinstimmende ClosingDate(s) aber nicht übereinstimmende Suchbegriffe auftauchen (diese sollen lediglich über eine MsgBox dem Anwender ausgegeben werden!).
Dies führt leider dazu, dass die weiteren "Treffer" nicht mehr weiter im wb1 transferiert werden und stattdessen auch als fehlend über MsgBox als Info erscheinen.
Habe schon viel versucht und komme einfach nicht weiter...
Glaube es liegt an der .Find Methode.
Danke für Rat und Hilfe! Grüße Heiko
Option Explicit
Sub Find ()
Dim wb1, wb2 As Workbook
Dim CloseDate As Date
Dim Jahr, Monat, AktJahr, AktMonat As String
Dim LastRowWs1 as Integer
Dim rng As Range
Dim Suchbegriff As String
Dim k As Integer
Set wb1 = Workbooks.Open(Filename:= "C\...")
Set wb2 = Workbooks.Open(Filename:= "C\...")
LastRowWs1 = wb1.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
wb2.Worksheets("Sheet1").Activate
With ActiveSheet.Range("E3")
Do Until .Offset(k,0).Value = ""
CloseDate = .Offset(k,0).Value
Jahr = Year(CloseDate)
Monat = Month(CloseDate)
AktJahr = Year(Now)
AktMonat = Month(Now)
If Monat = AktMonat And Jahr = AktJahr Then
Suchbegriff = .Offset(k, -3).Value
wb1.Worksheets("Sheet1").Activate
Set rng = ActiveSheet.Range("B:B")
If Not rng is Nothing Then
rng.EntireRow.Copy
ActiveSheet.Range("A" & LastRowWs1 + 1). PasteSpecial Paste:=xlPasteAll
Cells.(LastRowWs1 +1, 1).EntireRow.InteriorColor = vbYellow
rng.EntireRow.Delete
Else
MsgBox Suchbegriff & "wurde im wb2 nicht gefunden!", vbExlamation
End If
Application.CutCopyMode = False
End If
k=k+1
Loop
End With
End Sub