AW: Feedback
13.09.2020 12:21:15
fcs
Hallo Dominik,
Problem-Ursache: in Zelle K7 steht das Wort "Schrott". Deshalb wird die Zeile 7 (=Titelzeile) kopiert.
Du musst die Suche auf die Spalte B beschränken.
Ich hab dir auch noch eine etwas kompaktere Variante erstellt. Hier werden die Suchbegriffe in einer Schleife abgearbeitet. Insbesondere wenn du noch mehr Suchbegriffe hast, dann wird das Makro nicht ewig lang.
LG
Franz
Sub Buchen()
Dim strSuche As String, strSuche1 As String, raFund As Range
Dim raTreffer As Range, strFirst As String
strSuche = "Müll"
strSuche1 = "Schrott"
Application.ScreenUpdating = False
With Worksheets("Main")
Set raTreffer = Nothing
Set raFund = .Range("B:B").Find(what:=strSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Set raFund = .Range("B:B").FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With Worksheets("Mull")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
Set raTreffer = Nothing
Set raFund = .Range("B:B").Find(what:=strSuche1, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Set raFund = .Range("B:B").FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With Worksheets("Schrott")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
End With
Application.CutCopyMode = False
Set raFund = Nothing: Set raTreffer = Nothing
End Sub
Sub Buchen_Variante()
Dim strSuche As String, intSuche As Integer, raFund As Range
Dim wksZiel As Worksheet
Dim raTreffer As Range, strFirst As String
Application.ScreenUpdating = False
For intSuche = 1 To 2
Select Case intSuche
Case 1
strSuche = "Müll"
Set wksZiel = ThisWorkbook.Worksheets("Mull")
Case 2
strSuche = "Schrott"
Set wksZiel = ThisWorkbook.Worksheets("Schrott")
End Select
With Worksheets("Main")
Set raTreffer = Nothing
Set raFund = .Range("B:B").Find(what:=strSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Set raFund = .Range("B:B").FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With wksZiel
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
Set raTreffer = Nothing
End With
Next intSuche
Application.CutCopyMode = False
Set raFund = Nothing: Set raTreffer = Nothing
End Sub