Clever-Excel-Forum

Hallo zusammen,

ich hätte folgende Problemstellung, eventuell fällt ja jemandem von Euch was dazu ein Huh

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

Hallo,

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

(05.12.2017, 08:59)Jonas0806 schrieb: [ -> ]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

Hallo,

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

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

(05.12.2017, 11:35)Jonas0806 schrieb: [ -> ]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:

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

Alpha_2412

Jonas0806

Alpha_2412

Jonas0806

Jonas0806

Alpha_2412

Jonas0806