Mehrere Tabellen auslesen und in eine weiter neu zusammen setzen

[J. Juergensen]

Hallo, 
gesagt getan Uwe. 
Das klappt auch soweit alles ganz gut, ein Problem wird sein das die Nummer in der Übersicht vor den Gebäuden, 
keine fortlaufende Nummer ist.
Und die Gebäude auch keine fortlaufenden Nummern bekommen. (war schlecht kommuniziert von mir sorry)

Ich habe es zwar hinbekommen das Suchfeld abzufragen und die Ausgabe der Daten in die Tabelle "Suchen" zubringen aber,
die Ausgelesenen Daten werden immer wieder überschrieben.
Jetzt überlagern sich die  Ergebnisse von Tabelle 1, 2 und 3.
Desweiteren weiß ich leider auch nicht wie ich die Orts- und Gebäude-Angabe in die Tabelle "Suchen" bekomme.

Auch wenn es schon ein wenig frech klingt,   gibt es die Möglichkeit die Ausgelesenen Daten auf die zu Beschränken, die noch nicht erledigt sind?
Also sobald in der Zelle Erledigt ein Datum eingetragen wurde, soll diese bitte nicht mehr ausgelesen werden.   

Danke für die schnelle und nette Hilfe  :19: JJ

PS: Ich habe die "aktuelle Tabelle" nochmal mit geschickt

[schauan]

Hallöchen,

da geht im Code jetzt aber bisschen was durcheinander mit den Blättern Suche und Übersicht

Hier mal der geänderte Code. Die Daten werden jetzt auf dem Blatt Suche eingefügt. Die Übersicht bleibt jetzt außen vor.
In Spalte A schreib ich den Blattnamen, dann den "Rest". Es werden übrigens nicht alle zutreffenden Daten geholt, weil Du manchmal Fa. Mustermann hast und manchmal Fa.Mustermann

Code:

Option Explicit

Sub Makro1()
'Variablendeklarationen
Dim blaetter As Worksheet
Dim lRow As Long
'alte Daten entfernen
Sheets("Suche").Range("$A$5:$K$70").ClearContents
'Schleife ueber alle Blaetter
For Each blaetter In Worksheets()
  'mit dem Blatt
  With blaetter
    'Wenn der Blattname numerisch ist, dann
    If IsNumeric(.Name) Then
      'Autofilter in Zeile 2 setzen
      .Range("A2").AutoFilter
      'Filterkriterien festlegen
      .Range("$A$2:$H$71").AutoFilter Field:=5, Criteria1:= _
          Sheets("Suche").Range("B2").Value
      'gefilterte Liste kopieren - hier noch nicht beruecksichtigt, dass auch mal nix gefunden wird
      .Range("A3:H" & .Cells(.Rows.Count, 1).End(xlUp).Row).Copy
      'letzte gefuellte Zelle in Spalte D auf Suche feststellen, Mindestzeile 3
      lRow = WorksheetFunction.Max(Sheets("Suche").Cells(Sheets("Suche").Rows.Count, 4).End(xlUp).Row, 3)
      'laufende Nummer in Spalte A ermitteln und eintragen
      Sheets("Suche").Range("A" & lRow + 1) = WorksheetFunction.Max(Sheets("Suche").Range("A2:A20000")) + 1
      'Daten fuer Spalte A und B uebertragen
      Sheets("Suche").Range("A" & lRow + 1) = .Name
      Sheets("Suche").Range("B" & lRow + 1) = .Range("C1")
      Sheets("Suche").Range("C" & lRow + 1) = .Range("A1")
      'gefilterte Zeilen uebertragen
      Sheets("Suche").Range("D" & lRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
          :=False, Transpose:=False
      'Copymodus zuruecksetzen
      Application.CutCopyMode = False
      'Autofilter zuruecksetzen
      .Range("A2").AutoFilter
    'Ende Wenn der Blattname numerisch ist, dann
    End If
  'Ende mit dem Blatt
  End With
'Ende Schleife ueber alle Blaetter
Next
End Sub

[J. Juergensen]

vielen vielen Dank.

damit kann ich schon mal Arbeiten  :18:
Den zweiten Button mit der gefilterten suche bekomme ich bestimmt auch noch hin  :19: