Edit this "Looping" code to start and stop at specific times?

Bret1

Board Regular
Joined
Jun 14, 2013
Messages
199
I'm using this simple "Looping" code to make my Macro continuously loop every 5 minutes. Is there a way to edit this to make the macro 1st run at 8:15am, then every 5 min, then stop looping at 3:15pm?
I may open the worksheet and run the Macro before 8:30, but I don't want the Macro to execute until 8:15. I also want the Macro looping to execute immediately if I run the Macro after 8:15am, but before 3:15pm.
Thanks
Code:
Dim RunTimer As Date

Sub New_Copy_Over_Both_Columns()

RunTimer = Now + TimeValue("00:05:00")
Application.OnTime RunTimer, "New_Copy_Over_Both_Columns"
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
@MoshiM Code is working great! Could you show me how to insert "MACRO IS RUNNING" (as below) after approving the "Warning" question box, and remove "MACRO IS RUNNING" after the last loop? I'll post my total code and the 2 other codes I have below... Thanks again!
Insert "MACRO IS RUNNING" code...
Code:
'Insert "MACRO IS RUNNING" at (V6:V8) and turn cells light green
    Range("V6").Select
    ActiveCell.FormulaR1C1 = "MACRO"
    Range("V7").Select
    ActiveCell.FormulaR1C1 = "IS"
    Range("V8").Select
    ActiveCell.FormulaR1C1 = "RUNNING"
    Range("V6:V8").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    Range("A1").Select

Remove "MACRO IS RUNNING" and return cells to light red code...
Code:
'Remove "MACRO IS RUNNING" from (V6:V8) and color light red
    Range("V6:V8").Select
    Selection.ClearContents
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Range("A1").Select

My complete Macro...
Code:
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
    
' 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
    BoxOnce = True
  End If
    
  ' Set pause time between loops (hours, minutes, seconds)
    Const hourInterval As Integer = 0, minuteInterval As Integer = 5, secondInterval As Integer = 0
    
    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)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(15, 15, 5)
    
    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
            Exit Sub
        Else
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
        End If
        
    Else
        Exit Sub
    End If
    
    Debug.Print "Running at " & currentTime & ". Next call to procedure : " & RunTimer
    
  
   'Application.ScreenUpdating = False
    
    
    'Select X:X and shift to right
    Columns("X:X").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    'Select R:R and copy to X1
    Columns("R:R").Select
    Selection.Copy
    Range("X1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Font.Bold = False
    
    'Format Rows (1:1) as Time and (2:2) as Date
    Rows("1:1").Select
    Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Selection.Font.Bold = True
    Rows("2:2").Select
    Selection.NumberFormat = "m/d/yy"
    Selection.Font.Bold = True

    Application.CutCopyMode = False
    Columns("X:X").EntireColumn.AutoFit
 
    Application.ScreenUpdating = True
 '   ActiveWindow.Panes(3).Activate
    Range("A15").Select
    
    'Back Up Save at the end of every loop
        Application.ScreenUpdating = False
Application.DisplayAlerts = False
        With ActiveWorkbook
            .SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1 " & " "
            '.Close
        End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
   
End Sub
 
Upvote 0
@MoshiM Code is working great! Could you show me how to insert "MACRO IS RUNNING" (as below) after approving the "Warning" question box, and remove "MACRO IS RUNNING" after the last loop? I'll post my total code and the 2 other codes I have below... Thanks again!
Insert "MACRO IS RUNNING" code...
Code:
'Insert "MACRO IS RUNNING" at (V6:V8) and turn cells light green
    Range("V6").Select
    ActiveCell.FormulaR1C1 = "MACRO"
    Range("V7").Select
    ActiveCell.FormulaR1C1 = "IS"
    Range("V8").Select
    ActiveCell.FormulaR1C1 = "RUNNING"
    Range("V6:V8").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    Range("A1").Select

Remove "MACRO IS RUNNING" and return cells to light red code...
Code:
'Remove "MACRO IS RUNNING" from (V6:V8) and color light red
    Range("V6:V8").Select
    Selection.ClearContents
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Range("A1").Select

My complete Macro...
Code:
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
   
' 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
    BoxOnce = True
  End If
   
  ' Set pause time between loops (hours, minutes, seconds)
    Const hourInterval As Integer = 0, minuteInterval As Integer = 5, secondInterval As Integer = 0
   
    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)
    RunTimer = initialRunTimer
    finalTime = Date + TimeSerial(15, 15, 5)
   
    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
            Exit Sub
        Else
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
        End If
       
    Else
        Exit Sub
    End If
   
    Debug.Print "Running at " & currentTime & ". Next call to procedure : " & RunTimer
   
 
   'Application.ScreenUpdating = False
   
   
    'Select X:X and shift to right
    Columns("X:X").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
   
    'Select R:R and copy to X1
    Columns("R:R").Select
    Selection.Copy
    Range("X1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Font.Bold = False
   
    'Format Rows (1:1) as Time and (2:2) as Date
    Rows("1:1").Select
    Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Selection.Font.Bold = True
    Rows("2:2").Select
    Selection.NumberFormat = "m/d/yy"
    Selection.Font.Bold = True

    Application.CutCopyMode = False
    Columns("X:X").EntireColumn.AutoFit
 
    Application.ScreenUpdating = True
 '   ActiveWindow.Panes(3).Activate
    Range("A15").Select
   
    'Back Up Save at the end of every loop
        Application.ScreenUpdating = False
Application.DisplayAlerts = False
        With ActiveWorkbook
            .SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1 " & " "
            '.Close
        End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
   
  
End Sub
VBA Code:
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
    
   '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
        BoxOnce = True
    End If
    
  ' Set pause time between loops (hours, minutes, seconds)
    Const hourInterval As Integer = 0, minuteInterval As Integer = 5, secondInterval As Integer = 0
    
    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
            Exit Sub
        Else
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
        End If
    Else
        Exit Sub
    End If
    
    'Debug.Print "Running at " & currentTime & ". Next call to procedure : " & RunTimer
    
    'Application.ScreenUpdating = False
    'Insert "MACRO IS RUNNING" at (V6:V8) and turn cells light green
    with Range("V6:V8")
        .value=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
    end with
    '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
 
    Application.ScreenUpdating = True
 '   ActiveWindow.Panes(3).Activate
    'Range("A15").Select                <<<<<<<<<<    Do you need This?
    
    'Back Up Save at the end of every loop
    with Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    end with
    With ActiveWorkbook
        .SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1 " & " "
        '.Close
    End With
'Remove "MACRO IS RUNNING" from (V6:V8) and color light red
    with Range("V6:V8")
        .ClearContents
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent2
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With
    end with
    with Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    end with
   
End Sub
 
Upvote 0
VBA Code:
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
   
   '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
        BoxOnce = True
    End If
   
  ' Set pause time between loops (hours, minutes, seconds)
    Const hourInterval As Integer = 0, minuteInterval As Integer = 5, secondInterval As Integer = 0
   
    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
            Exit Sub
        Else
            Application.OnTime RunTimer, "New_Copy_Over_Both_Columns", Schedule:=True
        End If
    Else
        Exit Sub
    End If
   
    'Debug.Print "Running at " & currentTime & ". Next call to procedure : " & RunTimer
   
    'Application.ScreenUpdating = False
    'Insert "MACRO IS RUNNING" at (V6:V8) and turn cells light green
    with Range("V6:V8")
        .value=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
    end with
    '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
 
    Application.ScreenUpdating = True
 '   ActiveWindow.Panes(3).Activate
    'Range("A15").Select                <<<<<<<<<<    Do you need This?
   
    'Back Up Save at the end of every loop
    with Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    end with
    With ActiveWorkbook
        .SaveAs "C:\Users\Bret\Desktop\Scans" & "\" & "Scans " & Format(Now, "mm-dd-yy") & " Backed Up Every 5 Minutes 1 " & " "
        '.Close
    End With
'Remove "MACRO IS RUNNING" from (V6:V8) and color light red
    with Range("V6:V8")
        .ClearContents
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent2
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With
    end with
    with Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    end with
  
End Sub
This is working somewhat..... But I'd like for it to start up without showing the "Macro is Running", then immediately turn on the "Macro is Running" after "WARNING" box is approved and leave it on until the last loop is completed..... The "Macro is Running" may also have to be removed before saving, unless it is turned off at every start up.
 
Upvote 0
@MoshiM The last code you sent only displays the "Macro is running" while the Macro is actually looping, then auto-saves with it displayed, then removes it until the next loop begins. I'd like for it display as soon as "WARNING" is accepted and keep it displayed and maybe delete it after the last loop, or just delete it at each initial open..... For some reason it's only displaying "MACRO MACRO MACRO" at (V6:V8), instead of "MACRO IS RUNNING"
 
Upvote 0
@MoshiM The last code you sent only displays the "Macro is running" while the Macro is actually looping, then auto-saves with it displayed, then removes it until the next loop begins. I'd like for it display as soon as "WARNING" is accepted and keep it displayed and maybe delete it after the last loop, or just delete it at each initial open..... For some reason it's only displaying "MACRO MACRO MACRO" at (V6:V8), instead of "MACRO IS RUNNING"
Like this?
VBA Code:
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
 
Upvote 0
Like this?
VBA Code:
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
@MoshiM WOW!!!!! That appears to work perfect! Thank you so much!
 
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,268
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top