Do


SendKeys ("{CTRLDOWN}")
SendKeys ("{SHIFTDOWN}")
SendKeys ("{DOWN}")
SendKeys ("{CTRLUP}")
SendKeys ("{UP}")
SendKeys ("{RIGHT 24}")
SendKeys ("{SHIFTUP}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{C}")
SendKeys ("{CTRLUP}")



    Workbooks.Open Filename:= _
        "C:\Documents and Settings\mjksspf5\Desktop\Dump\Template.xls"


SendKeys ("{CTRLDOWN}")
SendKeys ("{LEFT}")
SendKeys ("{UP}")
SendKeys ("{CTRLUP}")
SendKeys ("{DOWN}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{V}")
SendKeys ("{CTRLUP}")
SendKeys ("{LEFT}")
SendKeys ("{F2}")
SendKeys ("{SHIFTDOWN}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{LEFT}")
SendKeys ("{SHIFTUP}")
SendKeys ("{C}")
SendKeys ("{CTRLUP}")
SendKeys ("{ENTER}")
SendKeys ("{ALTDOWN}")
SendKeys ("{O}")
SendKeys ("{H}")
SendKeys ("{R}")
SendKeys ("{ALTUP}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{V}")
SendKeys ("{CTRLUP}")
SendKeys ("{ENTER}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{PGDN}")
SendKeys ("{ALTDOWN}")
SendKeys ("{O}")
SendKeys ("{H}")
SendKeys ("{R}")
SendKeys ("{ALTUP}")
SendKeys ("{RIGHT}")
SendKeys ("{SHIFTDOWN}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{LEFT}")
SendKeys ("{SHIFTUP}")
SendKeys ("{V}")
SendKeys ("{CTRLUP}")
SendKeys ("{ENTER}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{PGUP}")
SendKeys ("{CTRLUP}")
SendKeys ("{ALTDOWN}")
SendKeys ("{F2}")
SendKeys ("{ALTUP}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{V}")
SendKeys ("{CTRLUP}")
SendKeys ("{ENTER}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{W}")
SendKeys ("{CTRLUP}")
SendKeys ("{LEFT}")
SendKeys ("{CTRLDOWN}")
SendKeys ("{DOWN}")
SendKeys ("{CTRLUP}")



Loop end

Sub CreateActivityReports()
    Dim wkbSource As Workbook, wkbTarget As Workbook
    Dim wstSource As Worksheet, wstTarget As Worksheet, wstJournal As Worksheet
    Dim rngActivityArea As Range, rngActivityFirstCell As Range, rngActivityLastCell As Range
    Dim rngTarget As Range
 
    Dim lngSourceLastRow As Long, lngSourceLastCol As Long
    Dim lngActivities As Long, lngActivity As Long
 
    Dim strActivityCode As String
 
    'change the paths here so they are correct (where your template/example is saved down)
    Set wkbTarget = Workbooks.Open("C:\Documents and Settings\****\Template***.xls")
    Set wkbSource = Workbooks.Open("C:\Documents and Settings\****Example***.xls")
 
 
    Set wstSource = wkbSource.Worksheets(1)
    Set wstTarget = wkbTarget.Worksheets(1)
    Set wstJournal = wkbTarget.Worksheets(2)
 
    'determine how many activity areas there are
    lngActivities = Application.CountA(wstSource.Range("A:A"))
 
    'less one to allow for the column header
    lngActivities = lngActivities - 1
 
    'determine the size of the entire range we want to extract the data from
    lngSourceLastRow = GetLastRow(wstSource.UsedRange)
    lngSourceLastCol = GetLastCol(wstSource.UsedRange)
 
    'we need to loop through each area of activity, transfer the area's activity into the template
    'and then save a copy of the template using the activity code
    For lngActivity = lngActivities To 1 Step -1
 
        'work out the last cell of the activity area
        If rngActivityFirstCell Is Nothing Then
            Set rngActivityLastCell = wstSource.Cells(lngSourceLastRow, lngSourceLastCol)
        Else
            Set rngActivityLastCell = wstSource.Cells(rngActivityFirstCell.Row - 1, lngSourceLastCol)
        End If
 
        'work out the first cell of the activity area
        Set rngActivityFirstCell = wstSource.Cells( _
            wstSource.Cells(rngActivityLastCell.Row, 1).End(xlUp).Row, 1)
 
        'get a reference to the activity area
        Set rngActivityArea = wstSource.Range(rngActivityFirstCell, rngActivityLastCell)
 
        'get a reference to the target area in the template workbook
        Set rngTarget = wstTarget.Range("A6").Resize( _
                            rngActivityArea.Rows.Count, _
                            rngActivityArea.Columns.Count)
 
        'assign across the values
        rngTarget.Value = rngActivityArea.Value
 
        'rename the tabs in the template
        strActivityCode = CStr(rngActivityArea.Cells(1).Value)
 
        wstTarget.Name = strActivityCode
        wstJournal.Name = "Journal " & strActivityCode
 
        'save a copy of the template
        wkbTarget.SaveCopyAs "C:\Documents and Settings\mjksspf5\Desktop\Dump\" & strActivityCode
 
        'clear the template ready for the next cycle
        rngTarget.ClearContents
 
    'move on to the next activity area
    Next lngActivity
 
    'close the workbooks we opened
    wkbTarget.Close savechanges:=False
    wkbSource.Close savechanges:=False
 
End Sub
 
Public Function GetLastRow(ByVal rngToCheck As Range) As Long
    Dim rngLast As Range
 
    Set rngLast = rngToCheck.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious)
 
    If rngLast Is Nothing Then
        GetLastRow = rngToCheck.Row
    Else
        GetLastRow = rngLast.Row
    End If
 
End Function
 
Public Function GetLastCol(ByVal rngToCheck As Range) As Long
    Dim rngLast As Range
 
    Set rngLast = rngToCheck.Find(what:="*", searchorder:=xlByColumns, searchdirection:=xlPrevious)
 
    If rngLast Is Nothing Then
        GetLastCol = rngToCheck.Column
    Else
        GetLastCol = rngLast.Column
    End If
 
End Function

wkbTarget.SaveCopyAs "C:\Documents and Settings\mjksspf5\Desktop\Dump\" & strActivityCode & ".xls"