Learn how to provision tenants, synchronize on-premise Active Directory, implement Single Sign-On, customize Office deployment, and protect your organization with eDiscovery and DLP policies. Only from Platform Scholar.
Become a Premium Member and unlock a new, free course in leading technologies each month.
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Private Sub CleanDataNotInTimeFrame()
Dim WS As Worksheet
Dim WSTemp As Worksheet
Dim StTime As Date, EndTime As Date
Dim MaxRow As Long, I As Long
Set WS = ActiveSheet
'---> Chk to see if Sheet Temp exist then delete it first
On Error Resume Next
Set WSTemp = Sheets("Temp")
If Err = 0 Then
WSTemp.Delete
End If
On Error GoTo 0
WS.Copy after:=Sheets(Sheets.Count)
Set WSTemp = ActiveSheet
WSTemp.Name = "Temp"
MaxRow = WSTemp.UsedRange.Rows.Count
StTime = WSTemp.Range("I10")
EndTime = WSTemp.Range("J10")
'---> Start Process
For I = MaxRow To 2 Step -1
If TimeValue(WSTemp.Cells(I, "A")) < StTime Or TimeValue(WSTemp.Cells(I, "A")) > EndTime Then
WSTemp.Range("A" & I & ":F" & I).Delete
End If
Next I
End Sub
Sub Convert_1to15()
Dim WS As Worksheet
Dim WSConv As Worksheet
Dim MaxRow As Long, MaxRowConv As Long, I As Long, J As Long, Incr As Long, StandardIncr As Long
Dim StRow As Long, EndRow As Long
'---> Disable Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
'---> CleanDataNotInTimeFrame
CleanDataNotInTimeFrame
Set WS = Sheets("Temp")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
'---> Check if Sheet 15 Min there
On Error Resume Next
Set WSConv = Sheets("15 Min")
If Err <> 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WSConv = ActiveSheet
WSConv.Name = "15 Min"
WS.Range("1:1").Copy WSConv.Range("A1")
WS.Range("A:A").Copy
WSConv.Range("A1").PasteSpecial xlPasteFormats
WSConv.Range("A1").Select
End If
MaxRowConv = 2
On Error GoTo 0
StandardIncr = 14
Incr = StandardIncr
'---> Start Process
For I = 2 + Incr To MaxRow Step Incr + 1
If I <> 2 + StandardIncr Then
'---> Check to see if Current set of dates falls all within the same date
If DateValue(WS.Cells(I - Incr, "A")) <> DateValue(WS.Cells(I, "A")) Then
J = I - Incr
Do
J = J + 1
Loop Until DateValue(WS.Cells(I - Incr, "A")) <> DateValue(WS.Cells(J, "A"))
Incr = J - 1 - (I - Incr)
I = I - StandardIncr
Else
Incr = StandardIncr
End If
End If
WSConv.Cells(MaxRowConv, "A") = WS.Cells(I, "A")
WSConv.Cells(MaxRowConv, "B") = WS.Cells(I - Incr, "B")
WSConv.Cells(MaxRowConv, "C") = WS.Application.WorksheetFunction.Max(WS.Range("C" & I - Incr & ":C" & I))
WSConv.Cells(MaxRowConv, "D") = WS.Application.WorksheetFunction.Min(WS.Range("D" & I - Incr & ":D" & I))
WSConv.Cells(MaxRowConv, "E") = WS.Cells(I, "E")
WSConv.Cells(MaxRowConv, "F") = WS.Application.WorksheetFunction.Sum(WS.Range("F" & I - Incr & ":F" & I))
MaxRowConv = MaxRowConv + 1
Incr = StandardIncr
Next I
'---> Enable Events
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox ("Conversion 1 to 15 Done")
End Sub
Option Explicit
Sub Convert_1to15()
Dim WS As Worksheet
Dim WSConv As Worksheet
Dim MaxRow As Long, MaxRowConv As Long, FirstLine As Long, IdxLine As Long
Dim StRow As Long, EndRow As Long
Application.ScreenUpdating = False
Set WS = ActiveSheet
MaxRow = WS.UsedRange.Rows.Count
'---> Check if Sheet 15 Min there
On Error Resume Next
Set WSConv = Sheets("15 Min")
If Err <> 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WSConv = ActiveSheet
WSConv.Name = "15 Min"
WS.Range("1:1").Copy WSConv.Range("A1")
WS.Range("A:A").Copy
WSConv.Range("A1").PasteSpecial xlPasteFormats
MaxRowConv = 2
Application.CutCopyMode = False
Else
WSConv.Rows("2:" & Rows.Count).EntireRow.ClearContents
MaxRowConv = WSConv.UsedRange.Rows.Count + 1
End If
On Error GoTo 0
FirstLine = 2
IdxLine = 2
Do
Do While (TimeValue(WS.Range("A" & FirstLine)) < TimeValue("9:15:00") Or _
TimeValue(WS.Range("A" & FirstLine)) > TimeValue("15:30:00"))
FirstLine = FirstLine + 1
If WS.Cells(FirstLine, 1) = "" Then
MsgBox "Done!"
Exit Sub
End If
Loop
IdxLine = FirstLine
Do While ((CLng(Mid(TimeValue(WS.Range("A" & IdxLine)), 4, 2)) + 1) Mod 15 <> 0 And _
TimeValue(WS.Range("A" & IdxLine)) < TimeValue("15:30:00"))
IdxLine = IdxLine + 1
Loop
WSConv.Cells(MaxRowConv, "A") = WS.Cells(IdxLine, "A")
WSConv.Cells(MaxRowConv, "B") = WS.Cells(FirstLine, "B")
WSConv.Cells(MaxRowConv, "C") = WS.Application.WorksheetFunction.Max(WS.Range("C" & FirstLine & ":C" & IdxLine))
WSConv.Cells(MaxRowConv, "D") = WS.Application.WorksheetFunction.Min(WS.Range("D" & FirstLine & ":D" & IdxLine))
WSConv.Cells(MaxRowConv, "E") = WS.Cells(IdxLine, "E")
WSConv.Cells(MaxRowConv, "F") = WS.Application.WorksheetFunction.Sum(WS.Range("F" & FirstLine & ":F" & IdxLine))
MaxRowConv = MaxRowConv + 1
FirstLine = IdxLine + 1
Loop While WS.Cells(FirstLine, 1) <> ""
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
RegardsSub Convert_1to15_Rgonzo1971()
Dim WS As Worksheet
Dim WSConv As Worksheet
Dim MaxRow As Long, MaxRowConv As Long, FirstLine As Long, IdxLine As Long
Dim StRow As Long, EndRow As Long
Dim BgnTime As Variant, EndTime As Variant
Application.ScreenUpdating = False
Set WS = Sheets("1 Min ")
MaxRow = WS.UsedRange.Rows.Count
'---> Check if Sheet 15 Min there
On Error Resume Next
Set WSConv = Sheets("15 Min")
If Err <> 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WSConv = ActiveSheet
WSConv.Name = "15 Min"
WS.Range("1:1").Copy WSConv.Range("A1")
WS.Range("A:A").Copy
WSConv.Range("A1").PasteSpecial xlPasteFormats
MaxRowConv = 2
Application.CutCopyMode = False
Else
WSConv.Rows("2:" & Rows.Count).EntireRow.ClearContents
MaxRowConv = WSConv.UsedRange.Rows.Count + 1
End If
On Error GoTo 0
BgnTime = WS.Range("I6")
EndTime = WS.Range("J6")
FirstLine = 2
IdxLine = 2
Do
Do While (TimeValue(WS.Range("A" & FirstLine)) < BgnTime Or _
TimeValue(WS.Range("A" & FirstLine)) > EndTime)
FirstLine = FirstLine + 1
If WS.Cells(FirstLine, 1) = "" Then
MsgBox "Done!"
Exit Sub
End If
Loop
IdxLine = FirstLine
Do While ((CLng(Mid(TimeValue(WS.Range("A" & IdxLine)), 4, 2)) + 1) Mod 15 <> 0 And _
TimeValue(WS.Range("A" & IdxLine)) < EndTime)
IdxLine = IdxLine + 1
Loop
WSConv.Cells(MaxRowConv, "A") = WS.Cells(IdxLine, "A")
WSConv.Cells(MaxRowConv, "B") = WS.Cells(FirstLine, "B")
WSConv.Cells(MaxRowConv, "C") = WS.Application.WorksheetFunction.Max(WS.Range("C" & FirstLine & ":C" & IdxLine))
WSConv.Cells(MaxRowConv, "D") = WS.Application.WorksheetFunction.Min(WS.Range("D" & FirstLine & ":D" & IdxLine))
WSConv.Cells(MaxRowConv, "E") = WS.Cells(IdxLine, "E")
WSConv.Cells(MaxRowConv, "F") = WS.Application.WorksheetFunction.Sum(WS.Range("F" & FirstLine & ":F" & IdxLine))
MaxRowConv = MaxRowConv + 1
FirstLine = IdxLine + 1
Loop While WS.Cells(FirstLine, 1) <> ""
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Do While ((CLng(Mid(TimeValue(WS.Range("A" & IdxLine)), 4, 2)) + 1) Mod 15 <> 0 And _
TimeValue(WS.Range("A" & IdxLine)) < EndTime)
Do While ((CLng(Mid(Format(TimeValue(WS.Range("A" & IdxLine)), "hh:mm"), 4, 2)) + 1) Mod 15 <> 0 And _
TimeValue(WS.Range("A" & IdxLine)) < EndTime)
Sub Convert_1to15() ' Version 5
Dim WS As Worksheet
Dim WSConv As Worksheet
Dim MaxRow As Long, MaxRowConv As Long, FirstLine As Long, IdxLine As Long
Dim StRow As Long, EndRow As Long
Dim BgnTime As Variant, EndTime As Variant
Application.ScreenUpdating = False
Set WS = Sheets("1 Min ")
MaxRow = WS.UsedRange.Rows.Count
'---> Check if Sheet 15 Min there
On Error Resume Next
Set WSConv = Sheets("15 Min")
If Err <> 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WSConv = ActiveSheet
WSConv.Name = "15 Min"
WS.Range("1:1").Copy WSConv.Range("A1")
WS.Range("A:A").Copy
WSConv.Range("A1").PasteSpecial xlPasteFormats
MaxRowConv = 2
Application.CutCopyMode = False
Else
WSConv.Rows("2:" & Rows.Count).EntireRow.ClearContents
MaxRowConv = WSConv.UsedRange.Rows.Count + 1
End If
On Error GoTo 0
BgnTime = WS.Range("I6")
EndTime = WS.Range("J6")
FirstLine = 2
IdxLine = 2
Do
Do While (TimeValue(WS.Range("A" & FirstLine)) < BgnTime Or _
TimeValue(WS.Range("A" & FirstLine)) > EndTime)
FirstLine = FirstLine + 1
If WS.Cells(FirstLine, 1) = "" Then
MsgBox "Done!"
Exit Sub
End If
Loop
IdxLine = FirstLine
Do While ((CLng(Split(TimeValue(WS.Range("A" & IdxLine)), ":")(1)) + 1) Mod 15 <> 0 And _
TimeValue(WS.Range("A" & IdxLine)) < EndTime)
IdxLine = IdxLine + 1
Loop
WSConv.Cells(MaxRowConv, "A") = WS.Cells(IdxLine, "A")
WSConv.Cells(MaxRowConv, "B") = WS.Cells(FirstLine, "B")
WSConv.Cells(MaxRowConv, "C") = WS.Application.WorksheetFunction.Max(WS.Range("C" & FirstLine & ":C" & IdxLine))
WSConv.Cells(MaxRowConv, "D") = WS.Application.WorksheetFunction.Min(WS.Range("D" & FirstLine & ":D" & IdxLine))
WSConv.Cells(MaxRowConv, "E") = WS.Cells(IdxLine, "E")
WSConv.Cells(MaxRowConv, "F") = WS.Application.WorksheetFunction.Sum(WS.Range("F" & FirstLine & ":F" & IdxLine))
MaxRowConv = MaxRowConv + 1
FirstLine = IdxLine + 1
Loop While WS.Cells(FirstLine, 1) <> ""
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Sub Convert_1to15()
Dim WS As Worksheet
Dim WSConv As Worksheet
Dim MaxRow As Long, MaxRowConv As Long, I As Long, J As Long, Incr As Long, StandardIncr As Long
Dim StRow As Long, EndRow As Long
'---> Disable Events
With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
'---> CleanDataNotInTimeFrame
CleanDataNotInTimeFrame
Set WS = Sheets("Temp")
MaxRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
'---> Check if Sheet 15 Min there
On Error Resume Next
Set WSConv = Sheets("15 Min")
If Err <> 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set WSConv = ActiveSheet
WSConv.Name = "15 Min"
WS.Range("1:1").Copy WSConv.Range("A1")
WS.Range("A:A").Copy
WSConv.Range("A1").PasteSpecial xlPasteFormats
WSConv.Range("A1").Select
End If
MaxRowConv = 2
On Error GoTo 0
StandardIncr = 14
Incr = StandardIncr
'---> Start Process
For I = 2 + Incr To MaxRow + Incr
If I <> 2 + StandardIncr Then
'---> Check to see if Current set of dates falls all within the same date
If WS.Cells(I, "A") = "" Then
J = I
Do
J = J - 1
Incr = Incr - 1
Loop Until IsDate(WS.Cells(J, "A"))
I = J
Else
If DateValue(WS.Cells(I - Incr, "A")) <> DateValue(WS.Cells(I, "A")) Or WS.Cells(I, "A") = "" Then
J = I - Incr
Do
J = J + 1
Loop Until DateValue(WS.Cells(I - Incr, "A")) <> DateValue(WS.Cells(J, "A"))
Incr = J - 1 - (I - Incr)
I = I - StandardIncr
Else
Incr = StandardIncr
End If
End If
End If
WSConv.Cells(MaxRowConv, "A") = WS.Cells(I, "A")
WSConv.Cells(MaxRowConv, "B") = WS.Cells(I - Incr, "B")
WSConv.Cells(MaxRowConv, "C") = WS.Application.WorksheetFunction.Max(WS.Range("C" & I - Incr & ":C" & I))
WSConv.Cells(MaxRowConv, "D") = WS.Application.WorksheetFunction.Min(WS.Range("D" & I - Incr & ":D" & I))
WSConv.Cells(MaxRowConv, "E") = WS.Cells(I, "E")
WSConv.Cells(MaxRowConv, "F") = WS.Application.WorksheetFunction.Sum(WS.Range("F" & I - Incr & ":F" & I))
MaxRowConv = MaxRowConv + 1
Incr = StandardIncr
I = I + Incr
Next I
'---> Enable Events
With Application
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox ("Conversion 1 to 15 Done")
End Sub
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.