Attribute VB_Name = "Module111"
'General Utilities
'-------------------------------------------
Sub Arrow(Direction, Optional N)

' move cursor N cells

'Examples:
'  Arrow "Right"
'  Arrow "Up"
'  Arrow "Left", 4

  ' Arrow Selects range which is destination cell
  
  'If N omitted or N<0 , then default N=1
  
  srow = ActiveCell.Row
  scol = ActiveCell.Column
  If IsMissing(N) Then
    N = 1
  ElseIf (N < 0) Then
    N = 1
  End If
  
  startcell = Cells(srow, scol).Address
  Direction = UCase(Direction)
   
  If (Direction = "UP") Then
    nextcell = Cells(WorksheetFunction.Max(1, srow - N), scol).Address
  ElseIf (Direction = "DOWN") Then
    nextcell = Cells(srow + N, scol).Address
  ElseIf (Direction = "LEFT") Then
    nextcell = Cells(srow, WorksheetFunction.Max(1, scol - N)).Address
  ElseIf (Direction = "RIGHT") Then
    nextcell = Cells(srow, scol + N).Address
  Else
    nextcell = startcell
  End If
    
  Range(nextcell).Select
  Range(nextcell).Activate
End Sub 'Arrow
  

Sub CopyDownNRows(addr, N)
    
' Example:
'    CopyDownNRows "G1", 24
'
'    will copy the contents of cell G1 to cells [G1:G24]
    
    Range(addr).Select
    Selection.Copy
    Range(addr).Select
    Arrow "Down", N - 1
    Range(ActiveCell, addr).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
End Sub 'CopyDownNRows

Sub ColPickup(Targ, Src, SrcSheet, LastRow, Optional FFF = "")
' For adding a col from Data to Rpt Gen
' intended for invocation from macro RptGen
'
' Targ is the cell addr in sheet Rpt Gen where the column begins
' Src is the cell addr in sheet SrcSheet where the column begins
' SrcSheet is the name of the Sheet where the data originates
' LastRow is the value of variant LastRow defined in RptGen
' FFF is optional format string
'
' ColPickup presumes that worksheet Containing the Targ cell (
' originally intended to be "Rpt Gen" or "Rpt Mo Gen") is active.
'
' Example:
'
' Sheets("Rpt Gen").Select
' ColPickup("AK1","AY1","Data",LastRow)
' ColPickup("AL1","BV1","MoData",LastRow,"#,##0")

Range(Targ).Formula = "='" & SrcSheet & "'!" & Src
If (FFF <> "") Then
  Range(Targ).NumberFormat = FFF
End If
CopyDownNRows Targ, LastRow
      
End Sub ' ColPickup


Sub WipeOut(TabName)

' Deletes (permanently) an existing tab
' Example:
'   WipeOut("Rpt Proc & Fail")
'     will delete tab "Rpt Proc & Fail", if it exists, from active Wbook

  For Each ws In ActiveWorkbook.Sheets
    If (ws.Name = TabName) Then
      Sheets(TabName).Select
      Application.DisplayAlerts = False
      ActiveWindow.SelectedSheets.Delete
      Application.DisplayAlerts = True
    End If
  Next
    
End Sub ' WipeOut

Sub MoveTab(TabName, Optional Tail As Variant = 0)

' If tab TabName exists, then MoveTab moves it to the beginning
' (leftmost) or, optionally, to the end of the list of tabs.
' Use Tail = 1 to move tab to tail end.
' Example:
'   MoveTab("Rpt Proc & Fail")
'     will move the tab "Rpt Proc & Fail", if it exists,
'     to the head of the list of tabs
'
' Dep: ArrangeTabs

  For Each ws In ActiveWorkbook.Sheets
    If (ws.Name = TabName) Then
      
      Sheets(TabName).Move Before:=Sheets(1) ' to Head
      If Tail = 1 Then
        Sheets("TabName").Move After:=Sheets(Sheets.Count) ' to Tail
      End If
      Exit For
      
    End If
  Next
    
End Sub ' MoveTab



Sub mcp(File)                 ' make timestamped copy of file

  Dim Copy As String
    
  '  Workbooks(File).Close SaveChanges:=True ' Close if open
  Workbooks.Open Filename:=File
  ActiveWorkbook.Save
  Copy = tsname(File)                     ' Get timestamped name
  ActiveWorkbook.SaveCopyAs (Copy)   ' Save timestamped Copy
  ActiveWorkbook.Close                    ' Close the file
  'Workbooks(Copy).Close SaveChanges:=True ' Close
    
End Sub 'mcp

Function tsname(File)
' Return name of a file with timestamp embedded in the name
' Usage:  NameWithTimestamp = tsname(Filename)
' See also: dsname()

Dim Copy As String
Dim Base As String
Dim Ext As String


  
  todya = Format(Now(), "yymmdd-hhmmss")  'The time right now
  
  'Break file name into Base and Ext
  DotLoc = 0
  SlsLoc = 0
  For i = Len(File) To 1 Step -1   ' seek extension at end of file name
    DotLoc = InStr(i, File, ".")
    SlsLoc = InStr(i, File, "\")
    If (DotLoc <> 0) Then Exit For         ' found a dot
    If (SlsLoc <> 0) Then Exit For         ' found a backslash
  Next

  If ((DotLoc = 0)) Then                       ' file has no extension
    Copy = File + "-" + todya                  ' append timestamp
        
  ElseIf ((DotLoc <> 0) And (SlsLoc = 0)) Then   ' file has extension
    Base = Mid(File, 1, DotLoc - 1)            ' Extract Base
    Ext = Mid(File, DotLoc + 1, Len(File))     ' Extract Extension
    Copy = Base + "-" + todya + "." + Ext      ' insert timestamp
    
  End If
  
  tsname = Copy
  
End Function 'tsname

Sub AGood(ToSh, ToCol, ToRow, _
          FrSh, FrCol, FrRow)

  ' Assigns value of one cell to value of another cell,
  ' only if value isn't empty
  
  ' ToSh is name of sheet to which to assign value (String)
  ' ToCol is column to which to assign value (String)
  ' ToRow is row to which to assign value (number)
  ' FrSh is name of shee from which to get value (String)
  ' FrCol is column from which to get value (String)
  ' FrRow is row from which to get value (number)
  
  ' Example:
  ' AGood("Rpt Gen", "BH", 3, _
                "MoData", "E", 18)
                
  ' Originally written for invocation from Sub RptProj
  
    
   
  If Not IsEmpty(Sheets(FrSh).Range(FrCol & FrRow).value) Then
    Sheets(ToSh).Range(ToCol & ToRow).value = Sheets(FrSh).Range(FrCol & FrRow).value
  End If
  
End Sub ' AGood
Sub BGood(ToSh, ToAddr, FrSh, FrAddr)
  ' Assigns value of one cell to value of another cell,
  ' only if value isn't empty
  '
  ' ToSh is name of sheet to which to assign value (String)
  ' ToAddr is address to which to assign value (String)
  ' FrSh is name of sheet from which to get value (String)
  ' FrAddr is column from which to get value (String)
  '
  ' See Sub AGood
  '
  ' Originally written for invocation from sub GPCpScr2DCh
  
   
  If Not IsEmpty(Sheets(FrSh).Range(FrAddr)) Then
    Sheets(ToSh).Range(ToAddr) = Sheets(FrSh).Range(FrAddr)
  End If
  
End Sub ' BGood

Function UseAsToday()
' Allows respecification of the value returned by Now()
' This permits some kinds of tests and recreations of
' conditions occurring on previous days.

UseAsToday = Now() ' default

End Function ' UseAsToday
Function BtwDol(Str)
' Returns the characters between the 1st and 2nd dollar signs in
' a string. Use to extract the column name from an address.
' (Sheesh -- there must be a better way!)
'
' Example:
'    BtwDol("$AJ$135") returns "AJ"

L = Len(Str)
j = 0
k = 0
For i = 1 To L
  If Mid(Str, i, 1) = "$" Then
    If j = 0 Then
      j = i + 1    ' 1st pos of st
      
    Else
      If k = 0 Then
        k = i - j  ' length of st
        Exit For
      End If ' k = 0
    End If ' j = 0 else
  End If ' mid = $
Next i

If k <= 0 Then
  RStr = ""
Else
  RStr = Mid(Str, j, k)
End If
    
BtwDol = RStr

End Function 'BtwDol