suche über mehrere Tabellenblätter

Hallo zusammen,
ich weiß hier nicht mehr weiter. Ich will eine Tabelle mit mehreren Blättern auswerten. Die Blätter sind alle gleich aufgebaut. In den Spalten AF und AG stehen die Suchkriterien und in Spalte D steht der zugehörige Name. Nun soll die Auswertung folgendermassen ablaufen: Es soll jedes Arbeitsblatt separat durchsucht werden nach dem Suchkriterium "gering". wenn also in den Spalten AF:AG jeweils "gering" steht, soll der Name aus Spalte D in ein neuangelegtes Tabellenblatt eingetragen werden. Jeder weitere gefundene Name soll dann in die nächste Zelle dahinter eingetragen werden. Als Überschrift über diese Namenszeile wäre dann der jeweilige Arbeitsblattname zu schreiben.
Das Ergebnis wäre also ein neues Tabellenblatt mit den verschiedenen Auswertungen über alle Tabellen blätter ungefähr in so einer Form:
---------------
NameBlatt1
gering - gering - Name1 - Name2 - Name3 - Name4...
NameBlatt2
gering - gering - Name1 - Name2 - Name3 - Name4...
NameBlatt3
gering - gering - Name1 - Name2 - Name3 - Name4...
---------------
Hat irgendjemand eine Idee, wie man soetwas am Besten umsetzt?
Vielen Dank schon mal im voraus für Eure Mühen
Gruß
Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Stefan,
teste mal.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub sucheAlleTabellen()
  Dim objSh As Worksheet, objNew As Worksheet
  Dim rng As Range, lngNext As Long, lngCol As Long
  Dim strSearch As String, strFirst As String
  
  On Error GoTo ErrExit
  GMS
  
  strSearch = "gering"
  
  lngNext = 1
  
  Set objNew = ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Sheets(1))
  objNew.Name = "Suche " & Format(Now, "ddMMyy hhmmss")
  
  For Each objSh In ThisWorkbook.Worksheets
    If Not objSh Is objNew Then
      lngCol = 2
      objNew.Cells(lngNext, 1) = objSh.Name
      objNew.Cells(lngNext + 1, 1) = strSearch & " - " & strSearch
      Set rng = objSh.Range("AF:AF").Find(What:=strSearch, LookIn:=xlValues, LookAt:=xlWhole, _
        MatchCase:=False, SearchFormat:=False)
      
      If Not rng Is Nothing Then
        strFirst = rng.Address
        Do
          If rng.Offset(0, 1) = strSearch Then
            objNew.Cells(lngNext + 1, lngCol) = objSh.Cells(rng.Row, 4).Value
            lngCol = lngCol + 1
          End If
          Set rng = objSh.Range("AF:AF").FindNext(rng)
        Loop While Not rng Is Nothing And strFirst <> rng.Address
      End If
      lngNext = lngNext + 3
    End If
  Next
  
  objNew.Columns.AutoFit
  
  ErrExit:
  GMS True
  Set rng = Nothing
  Set objSh = Nothing
  Set objNew = Nothing
End Sub

Public Sub GMS(Optional ByVal Modus As Boolean = False)
  
  Static lngCalc As Long
  
  With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Not Modus Then lngCalc = .Calculation
    If Modus And lngCalc = 0 Then lngCalc = -4105
    .Calculation = IIf(Modus, lngCalc, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    
  End With
  
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

suche über mehrere Tabellenblätter

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

336 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

suche über mehrere Tabellenblätter

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

336 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread