Option Explicit
Sub Start()
Dim Suche As String
Dim Blatt1 As String
Dim Blatt2 As String
Dim Blatt3 As String
Dim Blatt4 As String
Dim Blatt5 As String
Dim Blatt6 As String
Dim Blatt7 As String
Blatt1 = "1. Stock MZG"
Blatt2 = "5. Stock MZG"
Blatt3 = "6. Stock MZG"
Blatt4 = "7. Stock MZG"
Blatt5 = "8. Stock MZG"
Blatt6 = "1. Stock OEC"
Blatt7 = "2. Stock OEC"
Suche = "Poolraum"
If Len(Suche) Then
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True, Blatt1) & " Zeilen aus Blatt: " & Blatt1 & " kopiert!")
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True, Blatt2) & " Zeilen aus Blatt: " & Blatt2 & " kopiert!")
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True, Blatt3) & " Zeilen aus Blatt: " & Blatt3 & " kopiert!")
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True, Blatt4) & " Zeilen aus Blatt: " & Blatt4 & " kopiert!")
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True, Blatt5) & " Zeilen aus Blatt: " & Blatt5 & " kopiert!")
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True, Blatt6) & " Zeilen aus Blatt: " & Blatt6 & " kopiert!")
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True, Blatt7) & " Zeilen aus Blatt: " & Blatt7 & " kopiert!")
End If
End Sub
Function AuswahlKopieren(SuchStr As String, Optional Ganz As Boolean = False, Optional Arbeitsblattname As String) As Integer
Dim WSq As Worksheet
Dim WSz As Worksheet
Dim SuchColRng As Range
Dim FRng As Range
Dim CRng As Range
Dim CRangeCustom As Range
Dim FirstAdr As String
Dim CArr As Variant
Set WSq = Worksheets(Arbeitsblattname)
Set SuchColRng = WSq.Range("E:E")
Set CRangeCustom = WSq.Range("A:G")
Set WSz = Worksheets("Poolräume")
With SuchColRng
If Ganz Then
Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlWhole)
Else
Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlPart)
End If
If Not FRng Is Nothing Then
FirstAdr = FRng.Address
Do
If CRng Is Nothing Then
Set CRng = WSq.Rows(FRng.Row)
Else
Set CRng = Union(WSq.Rows(FRng.Row), CRng)
End If
Set FRng = .FindNext(FRng)
Loop While Not FRng Is Nothing And FRng.Address <> FirstAdr
End If
End With
If Not CRng Is Nothing Then
Set CRng = Intersect(CRng, CRangeCustom)
CRng.Copy
WSz.Cells(WSz.Cells(WSz.Rows.Count, SuchColRng.Column).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
AuswahlKopieren = CRng.Cells.Count / CRng.Rows(1).Cells.Count
Else
AuswahlKopieren = 0
End If
End Function
Function WSExists(ByVal WSName As String) As Boolean
Dim WS As Worksheet
For Each WS In Worksheets
If WS.Name = WSName Then
WSExists = True
Exit For
End If
Next
End Function