Übersicht aus mehreren Reitern erstellen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub Suchen() Dim lngRow As Long Dim objWorksheet As Worksheet Dim objCell As Range With ThisWorkbook.Worksheets("Übersicht") For lngRow = 2 To .Cells(.Rows.Count, 8).End(xlUp).Row For Each objWorksheet In ThisWorkbook.Worksheets If objWorksheet.Name "Allgemeines" Then If objWorksheet.Name "Übersicht" Then Set objCell = objWorksheet.Columns(8).Find( _ What:=.Cells(lngRow, 8).Value, LookIn:=xlValues, _ LookAt:=xlWhole, MatchCase:=False) If Not objCell Is Nothing Then Call objCell.EntireRow.Copy(Destination:=.Cells(lngRow, 1)) .Cells(lngRow, 14).Value = objWorksheet.Name Set objCell = Nothing Set objWorksheet = Nothing Exit For End If End If End If Next Next End With End Sub

Hallo Andreas,
die Reihenfolge der Tabellen spielt keine Rolle, die Schleife geht immer durch alle Tabellen bis der Suchbegriff gefunden wurde. Wenn du mehrere Tabellen ausschließen willst, dann kannst du das einfacher so machen:

Option Explicit

Public Sub Suchen()
    Dim lngRow As Long
    Dim objWorksheet As Worksheet
    Dim objCell As Range
    With ThisWorkbook.Worksheets("Übersicht")
        For lngRow = 2 To .Cells(.Rows.Count, 8).End(xlUp).Row
            For Each objWorksheet In ThisWorkbook.Worksheets
                Select Case objWorksheet.Name
                    Case "Allgemeines", "Übersicht", "xxx", "yyy", "zzz" 'Hier die Tabellennamen eintragen
                        'do nothing
                    Case Else
                        Set objCell = objWorksheet.Columns(8).Find( _
                            What:=.Cells(lngRow, 8).Value, LookIn:=xlValues, _
                            LookAt:=xlWhole, MatchCase:=False)
                        If Not objCell Is Nothing Then
                            Call objCell.EntireRow.Copy(Destination:=.Cells(lngRow, 1))
                            .Cells(lngRow, 14).Value = objWorksheet.Name
                            Set objCell = Nothing
                            Set objWorksheet = Nothing
                            Exit For
                        End If
                End Select
            Next
        Next
    End With
End Sub

Gruß
Nepumuk

Hallo Nepumuk,
nochmals vielen Dank!
Wenn du noch willst und etwas Zeit hast würden mich 1-3 Dinge zum Verständnis interessieren :).
Ich habe mal die Zeilen kommentiert was ich denke was dort passiert:

Option Explicit
Public Sub Suchen()
Dim lngRow As Long              'Variablendeklaration
Dim objWorksheet As Worksheet   'Variablendeklaration
Dim objCell As Range            'Variablendeklaration
With ThisWorkbook.Worksheets("Übersicht") 'In diesem Reiter sollen die Daten eingefügt  _
werden
For lngRow = 2 To .Cells(.Rows.Count, 8).End(xlUp).Row 'Starte in Zeile 2 und Spalte 8
For Each objWorksheet In ThisWorkbook.Worksheets 'Jedes Arbeitsblatt soll  _
durchsucht werden
Select Case objWorksheet.Name 'Fall 1 = durchsuche genannte Reiter nicht ||  _
Fall 2 = durchsuche alle bei Fall 1 nicht genannte Reiter
Case "Allgemeines", "Übersicht", "xxx", "yyy", "zzz" 'Hier die  _
Tabellennamen eintragen
'do nothing
Case Else 'Suche aktuellen Wert in Reiter "XYZ" (aktuelle Zeile Spalte 8)
Set objCell = objWorksheet.Columns(8).Find( _
What:=.Cells(lngRow, 8).Value, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then 'Wenn nichts gefunden wurde sucht er in  _
den anderen Reitern weiter
Call objCell.EntireRow.Copy(Destination:=.Cells(lngRow, 1)) 'Wenn  _
der Wert gefunden wurde dann ganze Zeile einfügen
.Cells(lngRow, 14).Value = objWorksheet.Name 'Name des Reiters wird  _
in Spalte 14 (N) eingetragen
Set objCell = Nothing 'Werte aus "Speicher" - leeren?
Set objWorksheet = Nothing 'Werte aus "Speicher" - leeren?
Exit For
End If
End Select
Next
Next
End With
End Sub

1:
For lngRow = 2 To .Cells(.Rows.Count, 8).End(xlUp).Row
Bedeutet es, dass wirklich die komplette Spalte 8 bis ganz nach unten durchgegangen wird? Oder wo stoppt er? Mit Count werden doch bestimmt Zeilen gezählt...
2:
Mein Arbeitskollege und ich haben festgestellt, dass es hilfreich wäre hinter Spalte 14 (N) Infos/Bemerkungsfelder einzufügen. Damit also nicht immer diese Felder überschrieben werden, sollten jedes mal nur Spalte 1-13 kopiert werden (In Spalte 14 wird ja der Name des Reiters eingetragen). Ich selbst würde es mit der Makroaufzeichnung machen und diese dann anpassen, aber es gibt doch bestimmt einen richtigen Code wie den "entireRow" wo man noch die gewünschten Spalten angeben kann...
3:
Wie kann ich nur die Werte kopieren? Manche Zellen haben Formeln und/oder sind farbig. Ich wollte ".PasteSpecial" an unterschiedlichen Stellen in dieser Zeile "Call objCell.EntireRow.Copy(Destination:=.Cells(lngRow, 1))" einfügen, aber irgendwie funktioniert das nicht so wie ich möchte...
Vorab nochmals vielen Dank für deine Hilfe :)
Gruß
Andreas

Option Explicit Public Sub Suchen() Dim lngRow As Long 'Variablendeklaration Dim objWorksheet As Worksheet 'Variablendeklaration Dim objCell As Range 'Variablendeklaration With ThisWorkbook.Worksheets("Übersicht") 'In diesem Reiter sollen die Daten eingefügt _ werden For lngRow = 2 To .Cells(.Rows.Count, 8).End(xlUp).Row 'Starte in Zeile 2 und Spalte 8 For Each objWorksheet In ThisWorkbook.Worksheets 'Jedes Arbeitsblatt soll _ durchsucht werden Select Case objWorksheet.Name 'Fall 1 = durchsuche genannte Reiter nicht || _ Fall 2 = durchsuche alle bei Fall 1 nicht genannte Reiter Case "Allgemeines", "Übersicht", "xxx", "yyy", "zzz" 'Hier die _ Tabellennamen eintragen 'do nothing Case Else 'Suche aktuellen Wert in Reiter "XYZ" (aktuelle Zeile Spalte 8) Set objCell = objWorksheet.Columns(8).Find( _ What:=.Cells(lngRow, 8).Value, LookIn:=xlValues, _ LookAt:=xlWhole, MatchCase:=False) If Not objCell Is Nothing Then 'Wenn nichts gefunden wurde sucht er in _ den anderen Reitern weiter Call objCell.Offset(0, -7).Resize(1, 13).Copy 'Wenn der Wert _ gefunden wurde dann Spalte 1-13 kopieren Call .Cells(lngRow, 1).PasteSpecial(Paste:= _ xlPasteValuesAndNumberFormats) 'Nur Werte und Zahlenformate einfügen .Cells(lngRow, 14).Value = objWorksheet.Name 'Name des Reiters wird _ in Spalte 14 (N) eingetragen Set objCell = Nothing 'Objekt aus "Speicher" - leeren Set objWorksheet = Nothing 'Object aus "Speicher" - leeren Exit For End If End Select Next Next End With End Sub

Beliebteste Forumthreads (12 Monate)

Übersicht aus mehreren Reitern erstellen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread