Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1920to1924
1920to1924
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Zeilenumbruch auslesen VBA

Forumthread: Zeilenumbruch auslesen VBA

Zeilenumbruch auslesen VBA
26.02.2023 10:11:51
maxi
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
Anzeige

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

Betreff
Datum
Anwender
Anzeige
AW: Zeilenumbruch auslesen VBA
26.02.2023 12:41:16
ralf_b
versuch macht klug. dein Wunschergebnis passt nicht zu den Ausgangsdaten. 
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

Anzeige
AW: Zeilenumbruch auslesen VBA
26.02.2023 13:02:18
AlterDresdner
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
Anzeige
AW: Zeilenumbruch auslesen VBA
26.02.2023 14:13:14
Maxi
Hallo,
das ist ja richtig abgefahren.
Der Code von AlterDresdner funktioniert super ... mit Kommentierung, einfach richtig professionell !!
Vielen, vielen Dank.
Super Forum !!!!!
Grüsse maxi
AW: Zeilenumbruch auslesen VBA
27.02.2023 11:49:12
Daniel
Hi
noch ne Variante
sollte bei großen Datenmengen etwas schneller sein, da das Ergebnis erst in einem Array gesammelt wird und dann als ganzes in einem Schritt ins Tabellenblatt geschrieben wird und nicht jede Zelle einzeln.
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

Anzeige
AW: Zeilenumbruch auslesen VBA
27.02.2023 15:03:50
Maxi
Hallo Daniel,
vielen Dank für den Code funktioniert super ;-).
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige