Hallo VBA Forum,

ich habe momentan ein kleines Raum-Projekt für die Arbeit. Ich habe eine Excel Datei die aus ~10 Arbeitsblättern besteht.

Jedes Arbeitsblatt bildet ein Stockwerk ab und beinhaltet alle Räume dieses Stockwerks

Ziel ist es alle Arbeitsblätter zu durchsuchen, und auf der ersten Seite alle Poolräume zusammenzustellen.

Von der ersten Seite aus soll es die Möglichkeit geben Einträge zu ändern(und dann automatisch auch im jeweiligen Arbeitsblatt).

Ich habe Erfahrungen mit OO Programmierung, aber keine VBA & Excel Erfahrungen.

Mein bisheriger Stand kopiert einfach nur alle poolräume in die erste seite, ich weiß leider nicht welche excel funktion am besten mein Problem lösen kann.

Ich habe mein code mal untenangehängt.

Mfg

Jack

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)
                    'MsgBox ("WSq.Rows(FRng.Row): " + WSq.Rows(FRng.Row))
                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
        'MsgBox ("WSz.Cells(WSz.Rows.Count, SuchColRng.Column).End(xlUp).Row +1: " & WSz.Cells(WSz.Rows.Count, SuchColRng.Column).End(xlUp).Row + 1)
        
        Application.CutCopyMode = False
        AuswahlKopieren = CRng.Cells.Count / CRng.Rows(1).Cells.Count
        'MsgBox ("CRng.Cells.Count: " & CRng.Cells.Count & " CRng.Rows(1).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