VBA fehlende Datum und Werte hinterlegen

Hallo Zusammen,
sorry zunächst für den nicht viel sagenden Betreff - mir ist aber keine andere Beschreibung eingefallen.
Ich bekomme aus einem Quellsystem eine Tabelle, in der zu jedem Arbeitstag (also ohne Sa. / So. und Feiertag) diverse Daten pro Kunde enthalten sind.
Es ist so das die nicht enthaltenen Tage auch nicht datumstechnisch vorhanden sind - die Tabelle springt bspw. vom 23.12.22 direkt auf den 27.12.22...
Ich müsste diese Tabelle nun so modifizieren, das einerseits die fehlenden Datumsangaben an entsprechender Stelle eingefügt werden und dort die weiteren Datensätze von dem unmittelbar davor liegendem Datum 1:1 reinkopiert werden.
Ich habe mal eine Beispieltabelle gemacht, in der die Spalten A bis E dem ensprechen was mir das Quellsystem liefert ... und die Spalten I bis M meine Wuschvorstellung wäre.
Vllt. hat einer von Euch ja eine Idee?
Vielen Dank vorab und viele Grüße
Addi
https://www.herber.de/bbs/user/157582.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub auffuellen() Dim objDatumA As Object, objDatumB As Object, oObj Dim vntIN, vntOUT() Dim i As Long, n As Long Dim lngMin As Long, lngMax As Long, lngDatum As Long, lngLast As Long Dim tmp Set objDatumA = CreateObject("scripting.dictionary") Set objDatumB = CreateObject("scripting.dictionary") lngMin = 99999 vntIN = Range("A1").CurrentRegion For i = 2 To UBound(vntIN) lngDatum = CLng(vntIN(i, 1)) lngMin = WorksheetFunction.Min(lngMin, lngDatum) lngMax = WorksheetFunction.Max(lngMax, lngDatum) objDatumA(lngDatum) = Array(vntIN(i, 2), vntIN(i, 3), vntIN(i, 4), vntIN(i, 5)) Next i 'überschriften objDatumB(vntIN(1, 1)) = Array(vntIN(1, 2), vntIN(1, 3), vntIN(1, 4), vntIN(1, 5)) For i = lngMin To lngMax If Not objDatumA.exists(i) Then objDatumB(i) = objDatumA(lngLast) Else objDatumB(i) = objDatumA(i) lngLast = i End If Next i ReDim vntOUT(1 To objDatumB.Count, 1 To 5) For Each oObj In objDatumB n = n + 1 vntOUT(n, 1) = oObj For i = 0 To UBound(objDatumB(oObj)) vntOUT(n, i + 2) = objDatumB(oObj)(i) Next i Next oObj Worksheets.Add.Cells(1, 1).Resize(UBound(vntOUT), UBound(vntOUT, 2)) = vntOUT End Sub

Hi
hier mal mein Ansatz, ist so ähnlich wie der von Rudi

Sub test()
Dim dicMin, dicMax
Dim arr
Dim z As Long
Dim K, I
Set dicMin = CreateObject("scripting.dictionary")
Set dicMax = CreateObject("scripting.dictionary")
arr = Cells(1, 1).CurrentRegion
For z = 2 To UBound(arr, 1)
    If dicMin.exists(arr(z, 2)) Then
        If dicMin(arr(z, 2)) > arr(z, 1) Then dicMin(arr(z, 2)) = arr(z, 1)
        If dicMax(arr(z, 2))  arr(z, 1) Then dicMax(arr(z, 2)) = arr(z, 1)
    Else
        dicMin(arr(z, 2)) = arr(z, 1)
        dicMax(arr(z, 2)) = arr(z, 1)
    End If
Next
For Each I In dicMin.Keys
    With Cells(Rows.Count, 1).End(xlUp).Resize(dicMax(I) - dicMin(I) + 1, 5)
        .Columns(2) = I
        .Columns(1).FormulaR1C1 = "=R[-1]C+1"
        .Cells(1, 1) = dicMin(I)
        .Columns(1).Formula = .Columns(1).Value
        .Columns(3).Resize(, 3).FormulaR1C1 = "=Index(C,Row()-1)"
    End With
Next
With Range("A:E")
    .RemoveDuplicates Array(1, 2), xlYes
    .Sort key1:=.Cells(1, 2), order1:=xlAscending, key2:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes
    With .CurrentRegion
        .Formula = .Value
    End With
End With
End Sub

auch hier werden zunächst einmal alle Zeilen neu angelegt, dh für jeden Kunden vom Start- bis zum Enddatum, dann werden aber die im Original vorhandenen Datensätze wieder gelöscht, so dass in der Neuanlage nur die fehlenden übrig bleiben.
Diese werden dann in die Liste einsortiert.
Da die fehlenden Inhalte per Formel aus den darüberliegenden Zellen übernommen werden, stimmen diese Daten erst nach dem sortieren.
Gruß Daniel

Sub M_snb() sn = Sheet1.Cells(1).CurrentRegion ReDim sp(UBound(sn) + 3 * UBound(sn) \ 7, UBound(sn, 2)) For j = 2 To UBound(sn) If sn(j, 2) > sn(j - 1, 2) Then y = sn(j, 1) t = 0 End If sp(n, 0) = y + t If sn(j, 1) > sp(n, 0) Then j = j - 1 For jj = 2 To UBound(sp, 2) sp(n, jj - 1) = sn(j, jj) Next n = n + 1 t = t + 1 Next Cells(1, 15).Resize(, UBound(sn, 2)) = Application.Index(sn, 1) Cells(2, 15).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp End Sub

Beliebteste Forumthreads (12 Monate)

VBA fehlende Datum und Werte hinterlegen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA fehlende Datum und Werte hinterlegen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread