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
Stock und Gebäude |
Raumnummer |
Institut/Professur |
Name |
Poolraum ja/nein |
belgete Zeit |
vergeben durch |
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
|