Excel: Werte aus einer Zeile in mehreren Zeilen auflisten

[BeWebb]

Hallo zusammen,

ich habe mich etwas im Forum eingelesen und leider nicht das passende gefunden, deswegen möchte ich mich gerne direkt an euch wenden und erbitte eure Hilfe.

Problem: Ich habe einen Kassenbericht und muss diesen derart umgestalten, dass 5 Werte aus einer (Datums-)Zeile untereinander gelistet werden, zusammen mit dem zugehörigen Datum und der jeweiligen Spaltenüberschrift.
Ein weiteres Problem ist auch, dass das Datum als Text formatiert ist und ich dies im Format DD.MM.JJ brauche.

Ich möchte anhand von Bildern verdeutlichen, was ich meine:
Diese Tabelle


Soll in etwa so aussehen (Datumsformat stimmt noch nicht):


Ich habe mir von einem ähnlichen Problem schon einen Code zusammengekratzt, es war aber letztendlich nicht zielführend. zur Veranschaulichung und ohne jeglichen Anspruch auf Eigenleistung (nur da, wo es nicht klappt, hab ich gewerkelt) kann ich ihn mal Posten

Sub ListeGenerieren()
    Dim sheet As Worksheet, rngOutCurrent As Range, rngInStop As Range, rngInStart As Range
    'Arbeitsblatt in dem die Artikel stehen
    Set sheet = Worksheets("Kasse")
    'Anfangszelle der Artikel setzen
    Set rngInStart = sheet.Range("A5")
    'Den letzen Artikel finden
    Set rngInStop = rngInStart.End(xlDown)
    'Ausgabe-Startzelle setzen
    Set rngOutCurrent = Worksheets("Tabelle2").Range("A2")
    'Für jede Zeile im Eingabebereich...
    For Each cell In sheet.Range(rngInStart, rngInStop)
        ' Spaltenbereich ...
        For i = 46 To 76
            'für die Spalten HIER STIMMT WAS NICHT
                Select Case i
                    Case 46, 49, 52, 74, 76
                End Select
            
            'Wenn die Menge der Staffel nicht leer ist dann ...
            If cell.Offset(0, i).Value <> "" Then
                'Artikelnamen schreiben
                rngOutCurrent.Value = cell.Value
                'Konstanten Wert 'Test' schreiben HIER MUSS SPALTENÜBERSCHRIFT hin
                rngOutCurrent.Offset(0, 1).Value = cell.Offset(a5, i).Value
                'Wert schreiben
                rngOutCurrent.Offset(0, 2).Value = cell.Offset(0, i).Value
                
                'Ausgabezeile um eine Zeile nach unten verschieben für den nächsten Eintrag
                Set rngOutCurrent = rngOutCurrent.Offset(1, 0)
            End If
        Next i
    Next
End Sub

Ich bekomme nicht hin, dass er bei der For-Schleife nur die Spalten 46, 49, 52, 74, 76 nimmt und dass in Spalte 2 jeweils die Spaltenüberschrift steht... und das leidige Datum..

Herzliche Dank vorab für eure Hilfe.

 

[Alchemist]

Wäre nicht vielleicht eine Pivottabelle einfacher? Beginnend mit A4 bis zur letzten Zelle unten rechts. Dort kannst du dann mit den Spaltenüberschriften schnell und einfach arbeiten.
Oder soll es unbedingt VBA sein? Geht natürlich auch.

 

[BeWebb]

Es muss nicht unbedingt VBA sein. Wenn die Tabelle die richtige Form hat, muss ich die werte noch einzelnen Konten zuordnen (vermutlich könnte man das hier auch automatisieren, die werte aus den Spalten werden immer aufs gleiche Konnte gebucht) und sie von DATEV einlesen lassen, dazu ist es eben zwingend erforderlich sein, dass spalten immer an der gleichen Stelle stehen und das Datum das richtige Format hat.

Mit Pivot habe ich es nicht lösen können.

 

[Snooty]

So könnte es klappen (blind getippt):

Dim wksA As Worksheet, wksB As Worksheet, sSpalte As String, i As Integer, k As Integer

Sub daten_übertragen()

Set wksA = Sheets("Tabelle1")
Set wksB = Sheets("Tabelle2")

For i = 5 To wksA.Range("A100000").End(xlUp).Row
  iLetzteZeile = wksB.Range("A100000").End(xlUp).Row
  
  For k = 0 To 4
    wksB.Range("A" & iLetzteZeile + k) = wksA.Range("A" & i) 'Datum
    Select Case k
      Case 0: sSpalte = "AU"
      Case 1: sSpalte = "AX"
      Case 2: sSpalte = "BA"
      Case 3: sSpalte = "BW"
      Case 4: sSpalte = "BY"
    End Select
    
    wksB.Range("B" & iLetzteZeile + k) = wksA.Range(sSpalte & "4") 'Überschrift
    wksB.Range("C" & iLetzteZeile + k) = wksA.Range(sSpalte & i) 'Wert
  
  Next k
  
Next i

End Sub

Wegen des Datums: welches Format hat das denn ursprünglich; ist das reiner Text oder schon ein richtiges Datum?

 

[BeWebb]

Herzlichen Dank, das funktioniert ganz hervorragend. Ein Problem gibt's nur bei der letzten Zeile: die führt er doppelt auf.



Der Export aus der Kasse erfolgt im csv-Format, dementsprechend ist die Zelle nicht als Datum Formatiert und ich kann sie nicht einfach umstellen.

 

[Snooty]

Für's Datum probiers mal damit:

sdatum = wksA.Range("A" & i) 'Text-Datum

iJahr = Right(sdatum, 4) * 1 'Jahr'
iTag = Mid(sdatum, Application.WorksheetFunction.Find(",", sdatum) + 2, 1) * 1 'Tag'
sMonat = Right(Left(sdatum, Len(sdatum) - 5), Len(Left(sdatum, Len(sdatum) - 5)) - Application.WorksheetFunction.Find(".", Left(sdatum, Len(sdatum) - 5)) - 1) 'Monat als String'

Select Case sMonat 'Monat als Integer'
  Case "Januar": iMonat = 1
  Case "Februar": iMonat = 2
  Case "März": iMonat = 3
  Case "April": iMonat = 4
  Case "Mai": iMonat = 5
  Case "Juni": iMonat = 6
  Case "Juli": iMonat = 7
  Case "August": iMonat = 8
  Case "September": iMonat = 9
  Case "Oktober": iMonat = 10
  Case "November": iMonat = 11
  Case "Dezember": iMonat = 12
End Select

wksB.Range("A" & iLetzteZeile + k) = DateSerial(iJahr, iMonat, iTag) 'Datum'

Wegen der letzten Zeile: am einfachsten Mal das Makro mit F8 schrittweise durchlaufen, damit du siehst, wieso er die letzte Zeile dupliziert.

 

[BeWebb]

Ich habe den Fehler gefunden: wenn er einmal durch war mit "k", hat er die letzte Zeile wieder überschrieben, ich habe mir wie folgt geholfen, ob das nun sauber ist, weiss ich nicht, aber es funktioniert. Dies ist jetzt der Code von Dir, der super funktioniert:

Dim wksA As Worksheet, wksB As Worksheet, sSpalte As String, i As Integer, k As Integer

Sub daten_übertragen()

Set wksA = Sheets("Tabelle1")
Set wksB = Sheets("Tabelle2")

For i = 5 To wksA.Range("A5000").End(xlUp).Row
  iLetzteZeile = wksB.Range("A5000").End(xlUp).Row

  For k = 0 To 4
        sdatum = wksA.Range("A" & i) 'Text-Datum
            iJahr = Right(sdatum, 4) * 1 'Jahr'
            iTag = Mid(sdatum, Application.WorksheetFunction.Find(",", sdatum) + 2, 2) * 1 'Tag'
            sMonat = Right(Left(sdatum, Len(sdatum) - 5), Len(Left(sdatum, Len(sdatum) - 5)) - Application.WorksheetFunction.Find(".", Left(sdatum, Len(sdatum) - 5)) - 1) 'Monat als String'

        Select Case sMonat 'Monat als Integer'
            Case "Januar": iMonat = 1
            Case "Februar": iMonat = 2
            Case "März": iMonat = 3
            Case "April": iMonat = 4
            Case "Mai": iMonat = 5
            Case "Juni": iMonat = 6
            Case "Juli": iMonat = 7
            Case "August": iMonat = 8
            Case "September": iMonat = 9
            Case "Oktober": iMonat = 10
            Case "November": iMonat = 11
            Case "Dezember": iMonat = 12
        End Select

        wksB.Range("A" & iLetzteZeile + k + 1) = DateSerial(iJahr, iMonat, iTag) 'Datum'

    Select Case k
      Case 0: sSpalte = "AU"
      Case 1: sSpalte = "AX"
      Case 2: sSpalte = "BA"
      Case 3: sSpalte = "BW"
      Case 4: sSpalte = "BY"
    End Select

    wksB.Range("B" & iLetzteZeile + k + 1) = wksA.Range(sSpalte & "4") 'Überschrift
    wksB.Range("C" & iLetzteZeile + k + 1) = wksA.Range(sSpalte & i) 'Wert

  Next k

Next i

End Sub

Ich danke dir nochmal sehr herzlich und versuche nun, den Rest allein zu lösen

Ergänzung (27. April 2017)

Ich muss nochmal nachfragen: Ich brauche das Datum offenbar doch im Format MMDDJJJJ
ohne Punkte. Wie muss ich den Code abändern?

 

[Snooty]

Sollte mit

 wksB.Range("A" & iLetzteZeile + k + 1) = Format(DateSerial(iJahr, iMonat, iTag), "mmddyyyy")

klappen (Zeile 32 oben im Code).

 

[BeWebb]

Guten Morgen.

Nein, das hat leider nicht geklappt. Es muss auch nicht zwingend Datumsformat sein, ich brauch im Prinzip nur die Info itag&imonat&ijahr aneinander gekettet.

edit: Hab es über Makro-Aufzeichnung angepasst und eingefügt, klappt jetzt wie gewünscht. Danke dir vielmals für deine Hilfe !