VBA Spalte ergänzen

[Alpha_2412]

Hallo zusammen,

ich hätte folgende Problemstellung, eventuell fällt ja jemandem von Euch was dazu ein  
Ich bekomme aus einem Programm eine Datei die X Tabellenblätter mit Reisekosten enthält.
Um diese weiter verabeiten zu können, füge ich in jedem Blatt eine neue Spalte A ein und füllte diese mit dem Blattnamen.

Wäre es möglich eine weitere Spalte einzufügen und diese mit der Reise-Nr. zu versehen, die über den blauen Zeilen in der Beispieldatei steht?
Das Problem ist, dass die Anzahl der Belege ja immer unterschiedlich ist und mehrere Reisen auf einem Blatt vorhanden sind.

Danke vorab für Eure Hilfe!

Viele Grüße
Alpha

[Jonas0806]

Hallo,

könntest Du bitte Deiner Datei ein Blatt zufügen, auf welchem Dein Wunschergebnis zu sehen ist?

[Alpha_2412]

Hallo,

könntest Du bitte Deiner Datei ein Blatt zufügen, auf welchem Dein Wunschergebnis zu sehen ist?

Hallo Jonas,

ich habe ein entsprechendes Blatt eingefügt.
Konkret geht es um die farblich (gelb und grau) markierte Zellen.
Den Namen bekomme ich bereits in die Spalte A und alle nicht benötigten Zeilen kann ich löschen.
Mir fehlt nur eine Möglichkeit die Reise-Nr. vor die jeweilige Buchungszeile zu übernehmen.

Danke und viele Grüße
Alpha

[Jonas0806]

Hallo,

das ist nicht ganz trivial. Ich schaue mal, ob ich heute noch dazu komme.

[Jonas0806]

Hallo,

so sollte es klappen

Code:

Option Explicit

Sub jonas0806()
   Dim arrTemp, arrNew()
   Dim strReise As String
   Dim wks As Worksheet
   Dim i As Long, j As Long
   
   For Each wks In ThisWorkbook.Worksheets
       arrTemp = wks.Range("A1:K" & wks.Cells(Rows.Count, 1).End(xlUp).Row)
       For i = LBound(arrTemp) To UBound(arrTemp)
           If (arrTemp(i, 1) <> "Tag") And (arrTemp(i, 1) <> "") Then
               If Left(arrTemp(i, 1), 5) = "Reise" Then strReise = arrTemp(i, 1): i = i + 2
               ReDim Preserve arrNew(12, j)
               arrNew(0, j) = wks.Name
               arrNew(1, j) = strReise
               arrNew(2, j) = arrTemp(i, 1)
               arrNew(3, j) = arrTemp(i, 2)
               arrNew(4, j) = arrTemp(i, 3)
               arrNew(5, j) = arrTemp(i, 4)
               arrNew(6, j) = arrTemp(i, 5)
               arrNew(7, j) = arrTemp(i, 6)
               arrNew(8, j) = arrTemp(i, 7)
               arrNew(9, j) = arrTemp(i, 8)
               arrNew(10, j) = arrTemp(i, 9)
               arrNew(11, j) = arrTemp(i, 10)
               arrNew(12, j) = arrTemp(i, 11)
               j = j + 1
           End If
       Next i
   Next wks
   With ThisWorkbook.Worksheets.Add
       .Cells(1, 1).Resize(UBound(arrNew, 2) + 1, 12) = Application.Transpose(arrNew)
   End With
End Sub

[Alpha_2412]

so sollte es klappen

Wow vielen Dank für die schnelle Antwort! Funktioniert (fast) perfekt!

Das Vorprogramm gibt teilweise Blätter mit Reisen aber ohne Belege aus (warum auch immer). Hier stößt der Code auf den Fehler "Laufzeitfehler 9: Index außerhalb des gültigen Bereichs" --> Siehe Musterdatei.
Falls es einen einfachen Weg gibt, diesen Fehler zu umgehen und das Blatt einfach zu überspringen wäre das Ergbnis perfekt, ansonsten würde ich die Tabelle vor dem Verarbeiten
einfach kurz durchschauen, ob dieser Fall vorliegt und die Blätter manuell rauslöschen.

Vielen Dank nochmal :19:

[Jonas0806]

Hallo Stefan,

sicher nicht die stabilste Version, aber vielleicht reicht es ja schon

Code:

Option Explicit

Sub jonas0806()
   Dim arrTemp, arrNew()
   Dim strReise As String
   Dim wks As Worksheet
   Dim i As Long, j As Long
   
   For Each wks In ThisWorkbook.Worksheets
       arrTemp = wks.Range("A1:K" & wks.Cells(Rows.Count, 1).End(xlUp).Row)
       If arrTemp(UBound(arrTemp), 1) <> "Tag" Then
           For i = LBound(arrTemp) To UBound(arrTemp)
               If (arrTemp(i, 1) <> "Tag") And (arrTemp(i, 1) <> "") Then
                   If Left(arrTemp(i, 1), 5) = "Reise" Then strReise = arrTemp(i, 1): i = i + 2
                   ReDim Preserve arrNew(12, j)
                   arrNew(0, j) = wks.Name
                   arrNew(1, j) = strReise
                   arrNew(2, j) = arrTemp(i, 1)
                   arrNew(3, j) = arrTemp(i, 2)
                   arrNew(4, j) = arrTemp(i, 3)
                   arrNew(5, j) = arrTemp(i, 4)
                   arrNew(6, j) = arrTemp(i, 5)
                   arrNew(7, j) = arrTemp(i, 6)
                   arrNew(8, j) = arrTemp(i, 7)
                   arrNew(9, j) = arrTemp(i, 8)
                   arrNew(10, j) = arrTemp(i, 9)
                   arrNew(11, j) = arrTemp(i, 10)
                   arrNew(12, j) = arrTemp(i, 11)
                   j = j + 1
               End If
           Next i
       End If
   Next wks
   With ThisWorkbook.Worksheets.Add
       .Cells(1, 1).Resize(UBound(arrNew, 2) + 1, 12) = Application.Transpose(arrNew)
   End With
End Sub