Zeile einfügen Daten übernehmen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc] Option Explicit Public Sub InsertMissingRows() Dim lngRow As Long Dim dtmNextTime As Date, dtmPreviousTime As Date Dim avntTemp As Variant With Worksheets("RMB Report") For lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1 dtmNextTime = CDate(Split(.Cells(lngRow, 1).Value, " ")(1)) dtmPreviousTime = CDate(Split(.Cells(lngRow - 1, 1).Value, " ")(1)) If Round(CDbl(dtmNextTime - dtmPreviousTime), 4) > _ Round(CDbl(TimeSerial(0, 15, 0)), 4) Then Call .Rows(lngRow).Insert avntTemp = Split(.Cells(lngRow - 1, 1).Value, " ") .Cells(lngRow, 1).Value = avntTemp(0) & _ Format$(dtmPreviousTime + TimeSerial(0, 15, 0), " Hh:Nn ") & avntTemp(2) Call .Range(.Cells(lngRow - 1, 2), .Cells(lngRow - 1, 10)).Copy( _ Destination:=.Cells(lngRow, 2)) lngRow = lngRow + 1 End If Next End With End Sub

Vielen Dank an alle die sich gemeldet haben und Ihre Hilfe angeboten haben.
Hallo Nepomuk
erstmal herzlichen Dank für deinen VBA Code !
Habe es ausprobiert und war zunächst überrascht wie gut es funktioniert hat.
Leider habe ich bei der Überprüfung feststellen müssen, dass meine Quelltabelle noch weitere Probleme hat.
Es fehlen nicht nur einzelne Zeilen sondern teilweise fehlen zwei oder mehr hintereinander folgende Zeilen und dazu kommt noch
dass die Quelltabelle auch mal zwischendurch ganz komische Zeit-Zeilen hat die überhaupt nicht in den 15 Min. Rhythmus passen.
Diese Zeilen sollten dann entfernt werden. Ziel sollte sein eine saubere Tabelle 24/h pro Tag mit 15 Min Abstand.
Kannst du mir nochmal helfen.
Ich habe heute vorsichtshalber mal die gesamte Quelltabelle neu (Betirebsdaten-2021-04.xlm hochgeladen.
Vielen Vielen Dank
LG W

Hallo Werner,
teste mal:

Code:


[Cc]




	
	
	
	


Option Explicit

Public Sub InsertMissingRows()

  Dim lngRow As Long, lngStartMinute As Long, lngRuningtMinute As Long
  Dim dblQuater As Double
  Dim dtmNextTime As Date, dtmPreviousTime As Date
  Dim avntTemp As Variant

  dblQuater = Round(CDbl(TimeSerial(0, 15, 0)), 4)

  With Worksheets("RMB Report")

      lngStartMinute = Minute(CDate(Split(.Cells(2, 1).Value, " ")(1)))

      For lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1

          lngRuningtMinute = Minute(CDate(Split(.Cells(lngRow, 1).Value, " ")(1)))

          If lngRuningtMinute <> lngStartMinute And lngRuningtMinute <> lngStartMinute + 15 And _
             lngRuningtMinute <> lngStartMinute + 30 And lngRuningtMinute <> lngStartMinute + 45 Then

             Call .Rows(lngRow).Delete

          End If
      Next

      For lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row To 3 Step -1

          avntTemp = Split(.Cells(lngRow, 1).Value, " ")
          dtmNextTime = CDate(Left$(avntTemp(0), 10) & " " & avntTemp(1))

          avntTemp = Split(.Cells(lngRow - 1, 1).Value, " ")
          dtmPreviousTime = CDate(Left$(avntTemp(0), 10) & " " & avntTemp(1))

          If Round(CDbl(dtmNextTime - dtmPreviousTime), 4) > dblQuater Then

             Call .Rows(lngRow).Insert

             .Cells(lngRow, 1).Value = Format$(dtmPreviousTime + _
             TimeSerial(0, 15, 0), "dd.mm.yyyy, Hh:Nn ") & "Uhr"

             Call .Range(.Cells(lngRow - 1, 2), .Cells(lngRow - 1, 10)).Copy( _
             Destination:=.Cells(lngRow, 2))

             lngRow = lngRow + 2

          End If
      Next
  End With
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Zeile einfügen Daten übernehmen

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeile einfügen Daten übernehmen

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread