Public RunTimer As Date
Dim BoxOnce As Boolean
Sub New_Copy_Over_Both_Columns()
Dim finalTime As Date, currentTime As Date, initialRunTimer As Date', RunTimer As Date
' Set pause time between loops (hours, minutes, seconds)
Const hourInterval As Integer = 0, minuteInterval As Integer = 5, secondInterval As Integer = 0
'Insert "WARNING" question box for auto-save
If BoxOnce = False Then
If MsgBox("WARNING: Auto-Save is Activated and may Save over today's data! Do you want to continue?", 36, "Confirm") = vbNo Then Exit Sub
'Insert "MACRO IS RUNNING" at (V6:V8) and turn cells light green
call Macro_Is_Running_Identifier(thisworkbook.activesheet,true)
BoxOnce = True
End If
On Error Resume Next
Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=False
On Error GoTo 0
'Set Start and Stop times for looping
initialRunTimer = Date + TimeSerial(8, 15, 5) '8:15:05 AM
RunTimer = initialRunTimer
finalTime = Date + TimeSerial(15, 15, 5) '3:15:05 PM
currentTime = Now
If currentTime < initialRunTimer Then
Application.OnTime initialRunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
Exit Sub
ElseIf currentTime >= initialRunTimer And currentTime < finalTime Then
RunTimer = currentTime + TimeSerial(hourInterval, minuteInterval, secondInterval)
If DateDiff("s", finalTime, RunTimer) = 0 Or RunTimer > finalTime Then
call Macro_Is_Running_Identifier(thisworkbook.activesheet,false)
Exit Sub
Else
Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
End If
Else
call Macro_Is_Running_Identifier(thisworkbook.activesheet,false)
Exit Sub
End If
'Application.ScreenUpdating = False
'Select X:X and shift to right
Columns("X:X").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Select R:R and copy to X1
Columns("R:R").Copy
with Range("X1")
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Font.Bold = False
end with
'Format Rows (1:1) as Time and (2:2) as Date
with Rows("1:1")
.NumberFormat = "[$-F400]h:mm:ss AM/PM"
.Font.Bold = True
end with
with Rows("2:2")
.NumberFormat = "m/d/yy"
.Font.Bold = True
end with
Application.CutCopyMode = False
Columns("X:X").EntireColumn.AutoFit
'Remove "MACRO IS RUNNING" from (V6:V8) and color light red
call Macro_Is_Running_Identifier(thisworkbook.activesheet,False)
' Application.ScreenUpdating = True
' ActiveWindow.Panes(3).Activate
with Application
.ScreenUpdating = False
.DisplayAlerts = False
end with
With ActiveWorkbook
'Back Up Save at the end of every loop
.SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1 " & " "
'.Close
End With
call Macro_Is_Running_Identifier(thisworkbook.activesheet,true)
with Application
.DisplayAlerts = True
.ScreenUpdating = True
end with
End Sub
Sub Macro_Is_Running_Identifier(WS as worksheet,turnGreen as boolean)
with Ws.Range("V6:V8")
if turnGreen then
'Insert "MACRO IS RUNNING" at (V6:V8) and turn cells light green
.value=WorksheetFunction.Transpose(Split("MACRO,IS,RUNNING", ","))
with .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
end with
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Font.Bold = True
Else
.ClearContents
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
end if
end with
End Sub
