Blätter mittels Schleife auslesen

Hallo zusammen,
ich habe mir folgendes einfaches Makro geschrieben.

Sub zusammentragen_aus_allen_roten_Reitern2()
Sheets("Blattübersicht").Select
Sheets("Blattübersicht").Range("A5000").End(xlUp).Offset(1, 0).Select
Dim Blatt As Worksheet
For Each Blatt In ActiveWorkbook.Worksheets
If Blatt.Tab.ColorIndex = 3 Then
Blatt.Select
Sheets("Blattübersicht").Range("A5000").End(xlUp).Offset(1, 0).Value = Blatt.Name
If Blatt.Range("C1")  "" Then
Sheets("Blattübersicht").Range("b5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C1")
Else
Sheets("Blattübersicht").Range("b5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C2")  "" Then
Sheets("Blattübersicht").Range("c5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C2")
Else
Sheets("Blattübersicht").Range("c5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C3")  "" Then
Sheets("Blattübersicht").Range("d5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C3")
Else
Sheets("Blattübersicht").Range("d5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C4")  "" Then
Sheets("Blattübersicht").Range("e5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C4")
Else
Sheets("Blattübersicht").Range("e5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C5")  "" Then
Sheets("Blattübersicht").Range("f5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C5")
Else
Sheets("Blattübersicht").Range("f5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C6")  "" Then
Sheets("Blattübersicht").Range("g5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C6")
Else
Sheets("Blattübersicht").Range("g5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C7")  "" Then
Sheets("Blattübersicht").Range("h5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C7")
Else
Sheets("Blattübersicht").Range("h5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C8")  "" Then
Sheets("Blattübersicht").Range("i5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C8")
Else
Sheets("Blattübersicht").Range("i5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C9")  "" Then
Sheets("Blattübersicht").Range("j5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("C9")
Else
Sheets("Blattübersicht").Range("j5000").End(xlUp).Offset(1, 0).Value = " "
End If
If Blatt.Range("C10")  "" Then
Sheets("Blattübersicht").Range("k5000").End(xlUp).Offset(1, 0).Value = Blatt.Range("c10")
Else
Sheets("Blattübersicht").Range("k5000").End(xlUp).Offset(1, 0).Value = " "
End If
End If
Next Blatt
Sheets("Blattübersicht").Select
ActiveWorkbook.Save
End Sub

Wie man sieht, viel Ahnung von VBA habe ich nicht. Vielleicht kann mir jemand bei einer Schleife helfen.
Aus allen roten Blättern sollen die Zellen C1 bis C65 in den Reiter "Blattübersicht" eingetagen werden. Die entsprechenden Zellen eines Blattes dann aber nicht untereinander, sonder nebeneinander. Wichtig: ist die Zellle leer, dann soll da eine Leerzeichen eingestellt werden.
Wer kann mir helfen?
Viele Grüße
Petra

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub zusammentragen_aus_allen_roten_Reitern2() Dim wsRot As Worksheet ' "Rote" Blätter Dim lngU As Long ' Zeilennr. in Übersicht Dim lngR As Long ' Zeilennr. in rotem Blatt With Sheets("Blattübersicht") lngU = .Cells(.Rows.Count, 1).End(xlUp).Row For Each wsRot In ActiveWorkbook.Worksheets If wsRot.Tab.ColorIndex = 3 And wsRot.Name .Name Then lngU = lngU + 1 .Cells(lngU, 1).Value = wsRot.Name For lngR = 1 To 65 If wsRot.Cells(lngR, 3) "" Then .Cells(lngU, lngR + 1).Value = wsRot.Cells(lngR, 3).Value Else .Cells(lngU, lngR + 1).Value = " " End If Next lngR End If Next wsRot .Select End With ActiveWorkbook.Save End Sub

Beliebteste Forumthreads (12 Monate)

Blätter mittels Schleife auslesen

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread