Datenlücken in Zeitreihen mit fehlenden Zeitstempeln füllen

Hallo zusammen,

in beigefügter Datei sind Sensorrohdaten in Form einer Zeitreihe über drei Tage zu sehen.
Die Sensoren geben in Abständen von fünf Minuten Daten aus. Pro Sensor wird also jedem 5-Minuten-Zeitstempel ein Wert zugeordnet (vorausgesetzt, der Sensor funktioniert).
Nun zum Problem: In der Nacht wird keine Einstrahlung gemessen und somit werden auch keine Zeitstempel erzeugt.

Siehe Zeile 6 im Bereich "Eingabe Rohdaten" sieht man, dass der Tag erst um 04:10 beginnt und in Zeile 172 sieht man, dass der Tag um 18:00 endet. Ziel ist es, die Sensorrohwerte jeweils zum Zeitstempel zuzuordnen. Jedoch sollen die Zeitstempel nachts in 5-Minutenschritten fortgeschrieben werden und jeweils den Wert "Null" aufweisen (siehe Spalte G-K "Zieldaten").

Händisch ist es möglich, jedoch bei mehreren Monaten an Datenmaterial sehr zeitaufwändig.

Nachfolgend die Beispieldatei:
https://www.herber.de/bbs/user/163978.xlsx

Vorab vielen Dank!

LG Marko

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo MarkoJ,

Hier ein Makro, dass im vorgegebenen Zeitraum prüft, ob ein Datensatz vorhanden ist.
ist er es nicht, wird er unten angefügt.
Anschließend werden die Nullen aufgeführt und formatiert.

Sub Rohdaten_vervollständigen()



    Dim min_date As Date

    Dim max_date As Date

    Dim Beginn As Date

    Dim Ende As Date

    Dim add_wert As Double

    Dim Wert As Double

    Dim lz As Long

    Dim nz As Long

    

    'Beginn der Aufzeichnungen

    min_date = Fix(WorksheetFunction.Min(Range("A:A")))

    max_date = Fix(WorksheetFunction.Max(Range("A:A")))

    

    Beginn = Application.InputBox("Ab wann sollen die Daten vervollständigt werden?", "Beginn", Format(CDate(min_date), "DD.MM.YYYY"))

    Ende = Application.InputBox("Bis wann sollen die Daten vervollständigt werden?", "Beginn", Format(CDate(min_date), "DD.MM.YYYY"))

    

    add_wert = 1 / 24 / 12 '5-min-Rhytmus

    Wert = CDate(Beginn) - add_wert

    lz = Cells(Rows.Count, "A").End(xlUp).Row + 1

    nz = lz

    Do

        Wert = Wert + add_wert 'neuen Wert

        Set gef = Range("A:A").Find(CDate(Wert), , , xlWhole) 'Wert vorhanden?

    

        If gef Is Nothing Then

            Cells(nz, "A") = CDate(Wert)

            nz = nz + 1

        End If

        

    Loop While CDate(Wert)  CDate(Ende) + 1 - add_wert

    

    Set Rng = Range("A" & lz & ":A" & nz - 1)

    Rng.NumberFormat = Range("A6").NumberFormat 'Formatierung wie in A6

    Set Rng = Range("B" & lz & ":E" & nz - 1)

    Rng.Value = 0 'Nullen auffüllen

    

    MsgBox nz - lz & " Rohdatensätze erzeugt", vbOKOnly + vbInformation



End Sub

Viel Erfolg!
Gruß, MCO

Sub Timeline() Dim TB1 As Worksheet, TB2 As Worksheet, dErster As Date, dTag As Date, dZeit As Date Dim Anz As Integer, Z1 As Integer, LR As Long, RNG As Range Set TB1 = Sheets("Eingabe Rohdaten") Set TB2 = Sheets("Zieldaten") Z1 = 6 ' Erste Zeile mit Daten 'reset TB2.UsedRange.ClearContents 'Kopfzeile kopieren TB1.Rows(Z1 - 1).Copy TB2.Rows(Z1 - 1) dErster = WorksheetFunction.Min(TB1.Columns(1)) dTag = Int(dErster) dZeit = dErster - dTag 'Anzahl Zeilen, die eingefügt werden müssen Anz = dZeit / TimeSerial(0, 5, 0) - 1 With TB2.Cells(Z1, 1).Resize(Anz, 1) 'Formel .FormulaR1C1 = "=DATEVALUE(""" & dTag & """) +TIME(0,5*(ROW()-" & Z1 & "+1),0)" 'Formel in Wert .Value = .Value End With LR = TB1.Cells(TB1.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte 'Daten kopieren TB1.Cells(Z1, 1).Resize(LR - Z1 + 1, 5).Copy TB2.Cells(Anz + Z1, 1) 'Datum formatieren TB2.Columns(1).NumberFormat = "DD.MM.YYYY hh:mm" 'Nullen auffüllen LR = TB2.Cells(TB2.Rows.Count, "A").End(xlUp).Row TB2.Cells(Z1, 2).Resize(LR - Z1 + 1, 4).SpecialCells(xlCellTypeBlanks).Value = 0 End Sub

Sub Timeline() Dim TB1 As Worksheet, TB2 As Worksheet, d1 As Variant, d2 As Date Dim Anz As Integer, Z1 As Integer, LR As Long, i As Long Dim WS Set TB1 = Sheets("Eingabe Rohdaten") Set TB2 = Sheets("Zieldaten") Set WS = WorksheetFunction Z1 = 6 ' Erste Zeile mit Daten 'Floor() = Untergrenze() wird verwendet, um Kleinstabweichungen in den Zeiten zu verhindern With TB1 If WS.Floor(.Cells(Z1, 1), TimeSerial(0, 5, 0)) > CDate(Int(WS.Min(Columns(1))) + TimeSerial(0, 5, 0)) Then .Rows(Z1).Insert .Cells(Z1, 1) = CDate(Int(WS.Min(Columns(1))) + TimeSerial(0, 5, 0)) End If LR = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte For i = LR To Z1 + 1 Step -1 d1 = WS.Floor(.Cells(i - 1, 1), TimeSerial(0, 5, 0)) d2 = WS.Floor(.Cells(i, 1), TimeSerial(0, 5, 0)) Anz = (d2 - d1) / TimeSerial(0, 5, 0) If Anz > 1 Then .Rows(i).Resize(Anz - 1).Insert With .Cells(i, 1).Resize(Anz - 1, 1) .FormulaR1C1 = "=FLOOR(R[-1]C +TIME(0,5,0),TIME(0,5,0))" .Value = .Value End With End If Next .Columns(1).NumberFormat = "DD.MM.YYYY hh:mm" LR = .Cells(.Rows.Count, "A").End(xlUp).Row .Cells(Z1, 2).Resize(LR - Z1 + 1, 4).SpecialCells(xlCellTypeBlanks).Value = 0 End With End Sub

Beliebteste Forumthreads (12 Monate)

Datenlücken in Zeitreihen mit fehlenden Zeitstempeln füllen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datenlücken in Zeitreihen mit fehlenden Zeitstempeln füllen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread