VBA Spalten an hand von Uhrzeiten reduzieren
07.05.2014 11:49:58
Uhrzeiten
ich habe folgendes Problem:
Ich habe div. Tabellenblätter mit Messdaten und Uhrzeitangaben in Dezimal und im Uhrzeitformat (Stunde, Minute, Sekunde). Nun brauche ich aber nur den ersten und letzten Wert der Messung sowie jede Minute dazwischen. Diese Zeilen müssen dann in ein neues Tabellenblatt kopiert werden. Da ich ca. 80 Tabellenblätter habe, die dazu alle anders heißen, gibt es eine Lösung in VBA? Ich habe da schon was, allerdings schreibt er mir nur den ersten Wert in ein neues Blatt und ich muß jedes Tabellenblatt anwählen.
Sub testines()
Dim DieseDatei As String
Dim DatName As String
Dim Vergleichs_Wert As Variant
Dim r As Long
Dim s As Integer
Dim Letzte_Reihe As Long
Dim Mldg, Titel, Voreinstellung
Dim ZellInhalt As Variant
Dim ZweiterIndex As Variant
'neues Tabellenblatt anlegen
Dim NewName As String
Debug.Print ActiveSheet.Name
Sheets.Add
NewName = InputBox("Geben Sie einen Tabellenblattnamen ein")
ActiveSheet.Name = NewName
i = 1
Sheets(i + 2).Activate
Range("e2").Select
Vergleichs_Wert = 0
' Vergleichs-Wert - Dialog
Mldg = "Bitte Vergleichs-Wert ( > 0 ) eingeben" ' Aufforderung festlegen.
Titel = "Parameter-Abfrage" ' Titel festlegen.
Voreinstellung = 0 ' Voreinstellung festlegen.
' Meldung, Titel und Standardwert anzeigen.
Vergleichs_Wert = InputBox(Mldg, Titel, Voreinstellung)
' Bei Abbruch
If Vergleichs_Wert = "" Then Exit Sub
' Umwandlung Input in Dezimal-Wert
Vergleichs_Wert = CDec(Vergleichs_Wert)
' Werte kleiner/gleich 0 ausschliessen
If (Vergleichs_Wert = 0 Or Vergleichs_Wert " & Vergleichs_Wert & " Vergleichs_Wert Then
' Datenreihe kopieren
Rows(r).Select
Selection.Copy
Sheets("Test").Activate
Range("A1").Activate
Selection.PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Sheets(i + 4).Activate
Range("e2").Select
ZweiterIndex = ZellInhalt
Letzte_Reihe = r
End If
' Naechste Reihe
r = r + 1
Cells(r, s).Select
Loop
'Falls letzte kopierte Reihe = letzte Reihe nicht doppelt kopieren
Letzte_Reihe = Letzte_Reihe + 1
If r - Letzte_Reihe > 0 Then
r = r - 1
Cells(r, s).Select
Call DatenKopieren
End If
Application.ScreenUpdating = True
End Sub
Kann mir jemand helfen?