ijd65

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0

ijd65

Sub Merge_Across()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

ijd65

Sub Merge_Down()
Dim ws As Worksheet
ActiveSheet.UsedRange.Offset(0).Clear
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.UsedRange.Copy
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

ijd65

Private Sub Rename()

  'Dim olTask As Outlook.TaskItem
  'Using object so all items can be processed
  Dim olitem As Object
  Dim olExp As Outlook.Explorer
  Dim fldCurrent As Outlook.MAPIFolder
  Dim olApp As Outlook.Application