Daten auslesen

Hallo Freunde,
kann man aus diesem Makro eine Schleife machen?
https://www.herber.de/bbs/user/44801.xls


Sub Ausführen()
Application.Run "Löschen"
Application.Run "Jahr2004"
Application.Run "Jahr2005"
Application.Run "Jahr2006"
Application.Run "Jahr2007"
Application.Run "Jahr2008"
End Sub


Sub Löschen()
Range("B2:B10").Select
Selection.ClearContents
Range("C2:C10").Select
Selection.ClearContents
Range("D2:D10").Select
Selection.ClearContents
Range("E2:E10").Select
Selection.ClearContents
Range("F2:F10").Select
Selection.ClearContents
Range("B2").Select
End Sub


Sub Jahr2004()
Dim c As Variant
Dim X As Double
For X = 2 To 10
Cells(X, 2) = ""
For Each c In Worksheets("Jahr2004").Range("A2:A100")
If c.Value = Worksheets("Gesamt").Cells(X, 2).Offset(0, -1).Value Then Worksheets("Gesamt"). _
Cells(X, 2) = Worksheets("Gesamt").Cells(X, 2) & " " & c.Offset(0, 1).Value
Next
Next
End Sub


Sub Jahr2005()
Dim c As Variant
Dim X As Double
For X = 2 To 10
Cells(X, 3) = ""
For Each c In Worksheets("Jahr2005").Range("A2:A100")
If c.Value = Worksheets("Gesamt").Cells(X, 3).Offset(0, -2).Value Then Worksheets("Gesamt"). _
Cells(X, 3) = Worksheets("Gesamt").Cells(X, 3) & " " & c.Offset(0, 1).Value
Next
Next
End Sub


Sub Jahr2006()
Dim c As Variant
Dim X As Double
For X = 2 To 10
Cells(X, 4) = ""
For Each c In Worksheets("Jahr2006").Range("A2:A100")
If c.Value = Worksheets("Gesamt").Cells(X, 4).Offset(0, -3).Value Then Worksheets("Gesamt"). _
Cells(X, 4) = Worksheets("Gesamt").Cells(X, 4) & " " & c.Offset(0, 1).Value
Next
Next
End Sub


Sub Jahr2007()
Dim c As Variant
Dim X As Double
For X = 2 To 10
Cells(X, 5) = ""
For Each c In Worksheets("Jahr2007").Range("A2:A100")
If c.Value = Worksheets("Gesamt").Cells(X, 5).Offset(0, -4).Value Then Worksheets("Gesamt"). _
Cells(X, 5) = Worksheets("Gesamt").Cells(X, 5) & " " & c.Offset(0, 1).Value
Next
Next
End Sub


Sub Jahr2008()
Dim c As Variant
Dim X As Double
For X = 2 To 10
Cells(X, 6) = ""
For Each c In Worksheets("Jahr2008").Range("A2:A100")
If c.Value = Worksheets("Gesamt").Cells(X, 6).Offset(0, -5).Value Then Worksheets("Gesamt"). _
Cells(X, 6) = Worksheets("Gesamt").Cells(X, 6) & " " & c.Offset(0, 1).Value
Next
Next
End Sub

Wobei ich zwischen Einträge wie sie in Zelle B2 ( siehe "https://www.herber.de/bbs/user/44801.xls" )durch ein Komma getrennt sein sollen und wenn in A9 kein Eintrag ist soll auch in den daneben stehende Zellen kein Wert eingetragen werden.
Hoffe das mir irgend jemand hilft ;-))
Gruß
j. Bode

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Ausführen() Dim inJahr As Integer Dim c As Range Dim X As Integer Dim wsTabelle As Worksheet Range("B2:F10").ClearContents For Each wsTabelle In Worksheets If Left(wsTabelle.Name, 4) = "Jahr" Then With wsTabelle For X = 2 To 10 For Each c In wsTabelle.Range("A2:A100") If c "" Then If c.Value = Worksheets("Gesamt").Cells(X, 1).Value Then Worksheets( _ "Gesamt").Cells(X, 2) = Worksheets("Gesamt").Cells(X, 2) & ", " & c.Offset(0, 1).Value End If Next Next .Range("B2:B10") = ClearContents End With End If Next wsTabelle End Sub

Sub Jahre(shName As String, iSpalte As Integer) Dim c As Variant Dim X As Double For X = 2 To 10 Cells(X, iSpalte) = "" For Each c In Worksheets(shName).Range("A2:A100") If c.Value = Worksheets("Gesamt").Cells(X, iSpalte).Offset(0, iSpalte * -1 + 1).Value Then Worksheets("Gesamt").Cells(X, iSpalte) = Worksheets("Gesamt").Cells(X, iSpalte) & " " & c. _ Offset(0, 1).Value End If Next Next End Sub

Sub Jahre(shName As String, iSpalte As Integer) Dim c As Variant Dim X As Double For X = 2 To 10 Cells(X, iSpalte) = "" For Each c In Worksheets(shName).Range("A2:A100") If c.Value = Worksheets("Gesamt").Cells(X, iSpalte).Offset(0, iSpalte * -1 + 1).Value Then If Not IsEmpty(c.Value) And Not IsEmpty(c.Offset(0, 1).Value) Then If Len(Worksheets("Gesamt").Cells(X, iSpalte)) > 0 Then Worksheets("Gesamt").Cells(X, iSpalte) = Worksheets("Gesamt").Cells(X, iSpalte) & ", " _ & c.Offset(0, 1).Value Else Worksheets("Gesamt").Cells(X, iSpalte) = c.Offset(0, 1).Value End If End If End If Next Next End Sub

Sub Ausführen() Dim inJahr As Integer Dim c As Range ' Variable für die Suchzelle Dim X As Integer ' Schleifenzähler Dim wsTabelle As Worksheet ' Variable für Tabelelnblatt als Objekt ' Bereich B2:F10 löschen Range("B2:F10").ClearContents ' Schleife über alle Tabellen For Each wsTabelle In Worksheets ' wenn die linken 4 Zeichen des Tabellennamens = "Jahr" sind If Left(wsTabelle.Name, 4) = "Jahr" Then ' führe in der betreffenden Tabelle aus With wsTabelle ' Schleife von 2 bis 10 For X = 2 To 10 ' durchsuche alle Zellen der Tabelle im Bereich As:A100 For Each c In wsTabelle.Range("A2:A100") ' wenn die Zelle leer ist If c "" Then ' wenn die Zelle = der Zelle in Spalte 1 (A) der laufenden Zeile _ dann ' Zelle in Spalte 1 (A) der laufenden Zeile = vorhandener Wert und " _ , " und Wert aus der Zelle rechts neben der gesuchten Zelle ' zusammensetzen If c.Value = Worksheets("Gesamt").Cells(X, 1).Value Then Worksheets( _ _ "Gesamt").Cells(X, 2) = Worksheets("Gesamt").Cells(X, 2) & ", " & c.Offset(0, 1).Value End If Next Next ' Bereich B2:B10 der laufenden Tabelle löschen .Range("B2:B10") = ClearContents End With End If Next wsTabelle End Sub

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread