sehr viele Kommentare
08.11.2010 10:35:34
Tino
Hallo,
habe mal sehr viele Kommentare dabei geschrieben, vielleicht hilft es Dir weiter.
Sub Test()
Dim oSH As Worksheet, rngDaten As Range
Dim strSuchBegriff$
Dim lngNextRow As Long
Dim iCalc As Integer
strSuchBegriff = "offen"
With Application
'Bildschirmaktualisierung, Eventmakros ausschalten
'Berechnung in einer Variable merken u. auf manuell stellen
'Dies bewirkt das der Bildschirm nicht so flackert und das der Code stabiler u. schneller läuft
iCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
With Sheets("offene Punkte")
'Tabelle leer machen ab A12 bis Ende Tabelle Spalte V
.Range("A12", .Cells(.Rows.Count, 22)).ClearContents
'erste einfüge Zeile, wo die erste gefundene Zeile reinkommt. (hier Zeile 12)
lngNextRow = 12
'Schleife über alle Tabellen
For Each oSH In ThisWorkbook.Worksheets
'Namen der Tabelle prüfen mit Musterübereinstimmung Name muss Whg Zahl.Zahl sein
'siehe auch in der VBA Hilfe unter 'Like (Operator)'
If oSH.Name Like "Whg #.#" Then
'Suche in Spalte V auf Tabelle oSh die Zellen mit dem Suchbegriff in strSuchBegriff
Set rngDaten = SucheDaten(oSH.Columns(22), strSuchBegriff)
If Not rngDaten Is Nothing Then 'gefunden?
For Each rngDaten In rngDaten.Areas 'gehe alle zusammenhängende Zellen durch
'kopiere die komplette Zeilen nach offene Punkte
rngDaten.EntireRow.Copy .Cells(lngNextRow, 1)
'Zähler für nächste Zeile
lngNextRow = lngNextRow + rngDaten.Rows.Count
Next rngDaten
End If
End If
Next
End With
'Bildschirmaktualisierung, Eventmakros wieder einschalten
'Berechnung auf den alten Zustand zurückstellen
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function SucheDaten(rngSucheIn As Range, strSucheNach$) As Range
Dim strErste$, rngFund As Range
'Suche Zellen mit dem Wert in strSucheNach
Set rngFund = rngSucheIn.Find(What:=strSucheNach, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'wurde eine Zelle gefunden?
If Not rngFund Is Nothing Then
'merke diese erste Adresse
strErste = rngFund.Address
'speichere diese in SucheDaten
Set SucheDaten = rngFund
'suche nächste mit diesem Begriff
Set rngFund = rngSucheIn.FindNext(rngFund)
'Schleife bis wieder die erste gefundene gefunden wird
Do While strErste <> rngFund.Address
Set SucheDaten = Union(rngFund, SucheDaten)
Set rngFund = rngSucheIn.FindNext(rngFund)
Loop
End If
End Function
Gruß Tino