Zeilenumbruch auslesen VBA

Hallo,
möchte zu den einzelnen Obst/Gemüse-Sorten (Spalte A) die im Zeilenumbruch (Spalte B-Bemerkung) eingetragenen Werte aufschlüsseln (Tabellenblatt "gewünschtes Ergebnis").
In der Spalte B sind Einträge mit einem "Datum" im Format "dd.mm." hinterlegt.
Dieses "Datum" soll im Format "dd.mm.yyyy" dargestellt werden.
Das Datum liegt immer in der Vergangenheit, entsprechend der Monatsangabe "mm" muss das entsprechende Jahr zugeordnet werden.
Das ist eine Beispieldatei, die Originaldatei hat viele solcher Einträge und ist vom Format nicht änderbar.
Kann man diese anspruchsvolle Aufgabe per VBA umsetzten und wie könnte ein Lösungsansatz aussehen?
https://www.herber.de/bbs/user/158017.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim arr, arr2, i&, cnt& arr = UsedRange cnt = 1 For i = LBound(arr) To UBound(arr) With Worksheets("gewünschtes Ergebnis") If i = 1 Then .Cells(1, 1) = "gewünschtes Ergebnis" Else cnt = cnt + 1 arr2 = Split(arr(i, 2), vbLf) .Cells(cnt, 1).Resize(UBound(arr2) + 1).Value = arr(i, 1) .Cells(cnt, 2).Resize(UBound(arr2) + 1).Value2 = Application.Transpose(arr2) cnt = cnt + UBound(arr2) End If End With Next End Sub

Hallo,
nicht ganz so elegant, dafür aber lesbarer und getestet und (hoffentlich) mit Berücksichtigung aller Eventualitäten

Sub Auseinander()
Const ObstSp = 1 'Spalte Obst
Const BemSp = 2 'Bemerkungsspalte
Dim Trenner
Dim Quelle As Object, Ziel As Object
Dim zeile As Long, zzeile As Long, a, b, j, k, Tag, Monat, Jahr, Dat, Bem As String, Obst As String
  Trenner = Chr(10) 'Trennzeichen in Quelle
  Set Quelle = ActiveSheet
  With Quelle
    Workbooks.Add
    Set Ziel = ActiveWorkbook.ActiveSheet
    zeile = 2
    zzeile = 2
    While Not IsEmpty(.Cells(zeile, ObstSp)) 'solange in QUelle was steht
      Obst = .Cells(zeile, 1)
      a = Split(.Cells(zeile, BemSp), Trenner)
      For Each b In a
        On Error Resume Next
        j = InStr(1, b, ".")
        Tag = Val(Left(b, j - 1))
        If Tag = 0 Or Tag > 31 Then Error (123)
        b = Mid(b, j + 1)
        k = InStr(1, b, ".")
        Monat = Val(Left(b, k - 1))
        If Monat = 0 Or Monat > 31 Then Error (123)
        Jahr = Year(Now()) - 1
        Select Case Monat - Month(Now())
        Case 0 'gleicher Monat
          If Tag  Day(Now()) Then Jahr = Jahr + 1
        Case Is > 0 'Monat in Zukunft
        Case Else 'Monat in Vergangenheit
          Jahr = Jahr + 1
        End Select
        Dat = DateSerial(Jahr, Monat, Tag)
        If Err.Number > 0 Then Dat = "Datum nicht auswertbar"
        On Error GoTo 0
        Bem = Mid(b, k + 2)
        Ziel.Cells(zzeile, 1) = Obst
        Ziel.Cells(zzeile, 2) = Dat
        'Ziel.Cells(zzeile, 2).NumberFormat = "dd.mm.yyyy"
        Ziel.Cells(zzeile, 3) = Bem
        zzeile = zzeile + 1
      Next b
      zeile = zeile + 1
    Wend
  End With
End Sub

Gruß der ALteDresdner

Sub test() Dim arr Dim erg Dim a As Long Dim x As Long Dim e As Long Dim TeilTexte Dim t As Long Dim Dat As String arr = Cells(1, 1).CurrentRegion 'Anzahl Zeile für Ergebnis berechnen For a = 2 To UBound(arr, 1) x = x + Len(arr(a, 2)) - Len(Replace(arr(a, 2), vbLf, "")) + 1 Next ReDim erg(1 To x, 1 To 3) For a = 2 To UBound(arr) TeilTexte = Split(arr(a, 2), vbLf) For t = 0 To UBound(TeilTexte) e = e + 1 erg(e, 1) = arr(a, 1) 'Obst ins Ergebnis x = InStr(4, TeilTexte(t), ".") 'Trennungposition zwsichen Datum und Text erg(e, 3) = Trim(Mid(TeilTexte(t), x + 1)) 'Text ins Ergebnis Dat = Mid(TeilTexte(t), 1, x) & Year(Now) 'Datum mit aktuellem Jahr If CDate(Dat) > Now Then Dat = Mid(TeilTexte(t), 1, x) & Year(Now) - 1 'prüfen ob Datum mit vorgängerjahr erforderlich erg(e, 2) = CDate(Dat) 'Datum ins Ergebnis Next Next 'Ergebnis ins Tabellenblatt Sheets("gewünschtes Ergebnis").Cells(2, 1).Resize(UBound(erg, 1), UBound(erg, 2)) = erg End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread