Nur in bestimmten Blättern Infos sammeln

Hallo Excel-Freunde,
ich habe gerade einen Knoten im Hirn und komme einfach nicht weiter.
Ich bekomme regelmäßig Exceldateien mit bis zu 150 Tabellenblätter. Diese will ich per Makro durchlaufen und bestimmte Zelleninhalten in ein neues Tabelleblatt "FP" kopieren. Das klappt mit der Select Case Schleife auch sehr gut, siehe unten.
Leider sind aber nicht alle Tabellenblätter relevant. Die Namen der relevanten Blätter sind aber im Blatt "Übersicht" in Spalte B aufgelistet, d.h. ich kann ich B2 den Zelleninhalt auslesen, damit nach dem bestimmten Blatt suchen und dann die Werte von dort in "FP" kopieren. Dann zurück in "Übersicht" und eine Zelle weiter nach unten.
Mehrere Kombinationen auch mit If...Then bringen mich aber nicht weiter.
Vielleicht habt ihr ja noch einen Tipp auf Lager.
Vielen Dank!

For Each Worksheet In Worksheets
Select Case Worksheet.Name
Case "Übersicht", "FP"
'Nix macha
Case Else
Worksheet.Activate
Abk = Range("C4")
Verant = Range("B4")
FNom = Range("H4")
'FP ansteuern
Worksheets("FP").Select
Worksheets("FP").Range("A1").Select
'eine Zeile weiter nach unten
If Worksheets("FP").Range("A1").Offset(1, 0)  "" Then
Worksheets("FP").Range("A1").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Abk
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Verant
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = FNom
End Select
Next Worksheet

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim InI as Integer
For Each Worksheet In Worksheets
Case Else
With Worksheets (cells(ini+1,A)
Abk = .Range("C4")
Verant = .Range("B4")
FNom = .Range("H4")
end With
Zu Deiner Datei kann ich nichts schreiben, was wohl daran liegt das ich nicht auf fremde Rechner schaue.Ich baue keine Datei nach.
Sollte die Datei verlinkt werden?
Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten
http://www.ms-office-forum.de/forum/showthread.php?t=322895
ändern.
Bilder lade ich mir nicht runter, da Excel damit nichts anfangen kann.
http://www.excel-ist-sexy.de/bilder-statt-datei/
Hochgeladene Bilder können zwar als solche in Excel importiert werden, sind jedoch bei der Lösung von Problemen nicht sehr hilfreich, da man die eigentlichen Daten nicht ohne große und zeitraubende Umwege direkt in die Tabelle übertragen kann.
Das ist nur meine Meinung zu dem Thema.
http://www.excel-ist-sexy.de/bilder-statt-datei/
Hochgeladene Bilder können zwar als solche in Excel importiert werden, sind jedoch bei der Lösung von Problemen nicht sehr hilfreich, da man die eigentlichen Daten nicht ohne große und zeitraubende Umwege direkt in die Tabelle übertragen kann.
Das ist nur meine Meinung zu dem Thema.
Grußformel

Option Explicit Public Sub Zusammenfassen() Dim objCell As Range Dim Abk As Variant, Verant As Variant, FNom As Variant With Worksheets("Übersicht") For Each objCell In .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)) With Worksheets(objCell.Value) Abk = .Range("C4").Value Verant = .Range("B4").Value FNom = .Range("H4").Value End With With Worksheets("FP") .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 3).Value = _ Array(Abk, Verant, FNom) End With Next End With End Sub

Public Sub Zusammenfassen() Dim objCell As Range Dim Abk As Variant, Verant As Variant, FNom As Variant With Worksheets("Übersicht") For Each objCell In .Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)) With Worksheets(objCell.Text) Abk = .Range("C4").Value Verant = .Range("B4").Value FNom = .Range("H4").Value End With With Worksheets("FP") .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 3).Value = _ Array(Abk, Verant, FNom) End With Next End With End Sub

Option Explicit Public Sub Zusammenfassen() Dim objCell As Range Dim Abk As Variant, Verant As Variant, FNom As Variant With Worksheets("Übersicht") For Each objCell In .Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)) If WorksheetExist(objCell.Text) Then With Worksheets(objCell.Text) Abk = .Range("C4").Value Verant = .Range("B4").Value FNom = .Range("H4").Value End With With Worksheets("FP") .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 3).Value = _ Array(Abk, Verant, FNom) End With End If Next End With End Sub Private Function WorksheetExist(ByVal pvstrWorksheetname As String) As Boolean Dim objWorksheet As Worksheet For Each objWorksheet In Worksheets If objWorksheet.Name = pvstrWorksheetname Then Set objWorksheet = Nothing WorksheetExist = True Exit For End If Next End Function

Beliebteste Forumthreads (12 Monate)

Nur in bestimmten Blättern Infos sammeln

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread