Pro Sekunde genau eine Wertezeile

Hallo zusammen,
ich habe ein kleines VBA-Problem, dass ich leider mit meinen doch noch
bescheidenen VBA-Kenntnissen nicht alleine lösen kann.
Das Problem ist folgendes:
Es handelt sich um eine Tabelle, die in Spalte A eine Uhrzeit enthält,
in Spalte B bis M sind unterschiedliche Werte eingetragen.
Gelgentlich kommt es vor, dass in aufeinanderfolgenden Zeilen
Werte zur selben Uhrzeit ausgegeben werden.
Andererseits kommt es auch vor, dass zu einer bestimmten Uhrzeit gar keine Werte vorhanden sind.
Das Ziel ist, zu jeder Sekunde genau eine Wertezeile zu haben.
Dazu müssten einerseits Zeilen gelöscht werden, wenn die Uhrzeit doppelt vorkommt
(immer die erste Zeile sollte optimalerweise stehen bleiben).
Wenn allerdings zu einer Sekunde keine Werte angegeben werden, sollten die Werte der vorherigen Sekunde auch für diese Sekunde eingetragen werden.
Da mein Problem relativ schwierig zu erklären ist, habe ich eine kleine Beispieldatei generiert:
https://www.herber.de/bbs/user/74950.xlsm
Ihr würdet mir wirklich weiterhelfen, wenn ihr eine Idee für ein Makro hättet!
Vielen Dank schon einmal im Voraus für eure Mühen!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Anja,
der Code bezieht sich auf die aktive Tabelle.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub anja()
  Dim vntOrg As Variant, vntVal As Variant, vntNew() As Variant
  Dim lngIndex As Long, lngC As Long, lngN As Long, lngI As Long
  Dim dblStart As Double, dblEnd As Double
  With ActiveSheet
    vntOrg = .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
    vntVal = .Range("B2:M" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
    dblStart = CDbl(vntOrg(1, 1))
    dblEnd = CDbl(vntOrg(UBound(vntOrg, 1), 1))
    lngC = (dblEnd - dblStart) * 86400 + 1
    Redim Preserve vntNew(1 To lngC, 1 To UBound(vntVal, 2) + 1)
    
    For lngIndex = 1 To UBound(vntNew, 1)
      vntNew(lngIndex, 1) = dblStart + TimeSerial(0, 0, lngIndex - 1)
    Next
    
    For lngIndex = 1 To UBound(vntNew, 1)
      lngN = Application.Match(CDbl(vntNew(lngIndex, 1)), vntOrg)
      For lngI = 2 To UBound(vntNew, 2)
        vntNew(lngIndex, lngI) = vntVal(lngN, lngI - 1)
      Next
    Next
    .Range("A2:M" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)).ClearContents
    .Range("A2").Resize(UBound(vntNew, 1), UBound(vntNew, 2)) = vntNew
  End With
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Pro Sekunde genau eine Wertezeile

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread