Results 1 to 10 of 10
  1. #1
    jeni_ojeni is offline Novice
    Windows 7 64bit Access 2010 64bit
    Join Date
    Sep 2016
    Posts
    4

    Export to template file beginning on row A3

    I have a report that I export to Excel, however, it came over with the headings from the query (which I don't want) instead of the ones from the Report (that I do want)

    So I made a nice template to replace the bad column headings and would like the report to start on A3 of the template.



    So I could either have code to change the existing columns OR export my report to an Excel template beginning on row A3.


    Any suggestions would be great!

  2. #2
    ItsMe's Avatar
    ItsMe is offline Sometimes Helpful
    Windows 8 Access 2013
    Join Date
    Aug 2013
    Posts
    7,862
    You might be able to start at A3 by placing some dummy records in the front of your report. You can also address the issue with the column headings by creating alias' in your query. So, just create the appropriate query and use the query as export.

    However, automating Excel and using CopyFromRecordset to a specific range might be the most straightforward.

    Something like this
    https://www.accessforums.net/showthr...089#post305089

  3. #3
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    You might also see Ken Snell's site http://www.accessmvp.com/kdsnell/EXCEL_MainPage.htm

  4. #4
    jeni_ojeni is offline Novice
    Windows 7 64bit Access 2010 64bit
    Join Date
    Sep 2016
    Posts
    4
    Hello,
    so i found another site using the following code. who also wanted to export to a certain file and on a certain row like me. So i copied the code BUT I have a command button that exports the data and I can't seem to get them to work together and the error stops on the objConnection part of the code. I am stuck! Any suggestions?

    Public Sub CreateExcelInfo()
    'Set reference to Microsoft Excel Object library
    'Set reference to Microsoft ActiveX DataObject 2.x
    Const sFileNameTemplate As String = "PathAndNameOfYourTemplateXLSX"
    Dim oExcel As New Excel.Application
    Dim WB As New Excel.Workbook
    Dim WS As Excel.Worksheet
    Dim rng As Excel.Range
    Dim objConn As New ADODB.Connection
    Dim objRs As New ADODB.Recordset
    Dim vData As Variant
    Dim sSQL As String
    Set objConn = CurrentProject.Connection
    sSQL = "Select * from qTheQuery" 'This has to be the name of the query your report is using to display data
    With objRs
    .Open sSQL, objConn, adOpenStatic, adLockReadOnly
    vData = .GetRows()
    .Close
    End With
    With oExcel
    .Visible = True
    'Create new workbook from the template file
    Set WB = .Workbooks.Add(sFileNameTemplate)
    With WB
    Set WS = WB.Worksheets("Sheet1") 'Replace with the name of actual sheet
    With WS
    Set rng = .Range("A1") 'Starting point of the data range
    rng.Resize(UBound(vData, 2) + 1, UBound(vData, 1) + 1).Value = oExcel.WorksheetFunction.Transpose(vData)
    End With

    End With

    .Quit
    End With

    'clean up
    Set oExcel = Nothing
    Set objRs = Nothing
    Set objConn = Nothing
    Set vData = Nothing
    End Sub

    Private Sub cmdEXPORT_Click()


    End Sub

  5. #5
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    Code:
    'Set reference to Microsoft Excel Object library
    'Set reference to Microsoft ActiveX DataObject 2.x (2.8 for A2010)
    I don't use ADO (haven't needed to), so I'm not well versed in ADO.
    First thought is "Did you set the references"?

  6. #6
    jeni_ojeni is offline Novice
    Windows 7 64bit Access 2010 64bit
    Join Date
    Sep 2016
    Posts
    4
    Yes I set to reference, but the reference I chose was Excel and Access 14.0 and ActiveX 2.8. Now it highlights Private Sub cmdEXPORT_Click() - I am such a beginner, that I can't tell what is wrong (i'm learning pretty fast thanks to everyone's help!). Also, should i change ADO?

  7. #7
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    Also, should i change ADO?
    Don't know. I know nothing about yor project or requirements to say.

    ------------------------------------
    In your first post, you said
    Quote Originally Posted by jeni_ojeni View Post
    I have a report that I export to Excel, however, it came over with the headings from the query (which I don't want) instead of the ones from the Report (that I do want)
    Quote Originally Posted by jeni_ojeni View Post
    So I could either have code to change the existing columns OR export my report to an Excel template beginning on row A3.
    I had kind of the same requirement. What I did was to use "DoCmd.OutputTo" to get the data to an Excel Workbook, then use automation to edit the spreadsheet.

    My subroutine adds two rows at the top, adds titles, selects rows and columns, removes any borders, adds a thick border at the last row and finally, adds totals formulas.
    (looking at the code now, I need to clean it up. At the time I was under pressure to have it done yesterday, so the code isn't the best - it was in A2K .... but it works )

  8. #8
    jeni_ojeni is offline Novice
    Windows 7 64bit Access 2010 64bit
    Join Date
    Sep 2016
    Posts
    4
    Thanks ssanfu, i am such a noobe that I don't know how to do the subroutine. or us the automation to edit the spreadsheet. do you have a code I can copy? I did use the DoCmd.OutputTo and that worked, but that all I did.

    Thanks
    Jenn

  9. #9
    ssanfu is offline Master of Nothing
    Windows XP Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    I don't know how much help this will be since this is specific to my query/report.

    So I ran the DoCmd.Output command, then made a copy of the spreadsheet.
    In the original spreadsheet, I recorded VBA code as I modified the worksheet like I needed it to look.
    Then I used that code (what Excel calls a "Macro") and wrote the following subroutine.

    I deleted the original workbook (because it had the modifications), then created a copy of the original copy, deleting the "Copy"s so it was named like the original.
    Example:
    original WK name = "Book1.xlsx"
    Copy = "Copy of Book1.xlsx"
    Delete "Book1.xlsx"
    make copy - "Copy of Copy of Book1.xlsx"
    rename to "Book1.xlsx"


    Now I write the code to do the edits to the SS using the code in the SS as a reference.
    I can single step through the subroutine to make sure the edits happen correctly and in the correct order.
    If I have to make changes to the code, I delete the SS, make another copy of the copy and rename it.
    Step through the code again.
    Repeat until the edits are correct.



    I have a "Reports" form with a list box of the reports I can print or export. I select a report and click a
    "Print" button to print a hard copy or an
    "Export" button to export the report query as an Excel SS, which then calls the workbook edit code.

    Your code will be different from mine.... you might not need all the parameters I have.

    ------------
    This how I call the sub:
    Code:
    <snip>
        'output query to Excel
        DoCmd.OutputTo acOutputQuery, "EQ_StatementMonthlySummary", acFormatXLSX, strSaveFileName, False
        'modify the Excel workbook
        Call EditVendorWkSht(strSaveFileName, "Statement Monthly Summary", Me.cboMonth & " " & Me.cboYear & " Hours")
    <snip>
    This is the sub that modifies the Excel workbook for the specific report.
    Code:
    Sub EditVendorWkSht(pWkshtPathName As String, pReportName As String, pMthYr As String)
       'pWkshtPathName - the fully qualified path and file name  (strSaveFileName)
       'pReportName - name of the report that was output  (this is for report '"Statement Monthly Summary"')
       'pMthYr - a string of the month, year and text string  (the month & year of the report)
    
        Dim xlx As Object  'Excel
        Dim xlw As Object  'workbook
        Dim xls As Object  'worksheet
    
        Dim sRow As Integer
        Dim eRow As Integer
        Dim RowDiff As Integer
    
        Dim blnEXCEL As Boolean
    
    
        blnEXCEL = False
    
        ' Establish an EXCEL application object
        On Error Resume Next
        Set xlx = GetObject(, "Excel.Application")
        If Err.Number <> 0 Then
            Set xlx = CreateObject("Excel.Application")
            blnEXCEL = True
        End If
        Err.Clear
        On Error GoTo 0
    
        ' Change True to False if you do NOT want the workbook to be visible
        '  when the code is running
        '    xlx.Visible = True
        xlx.Visible = False
    
        ' the EXCEL file into which you will write the data
        Set xlw = xlx.Workbooks.Open(pWkshtPathName)
    
        ' Select a worksheet
        ' (note that the worksheet must already be in the EXCEL file)
        Set xls = xlw.Worksheets(1)
    
    
        '**** Start editing the worksheet *****
    
        'ensure correct report
        If pReportName = "Statement Monthly Details" Then
    
            'add two rows at the top
            xls.Rows("1").EntireRow.Insert
            xls.Rows("1").EntireRow.Insert
    
            xls.Range("A1").Select
            xls.Range("A1").FormulaR1C1 = pReportName  'report name
    
            xls.Range("A2").Select
            xls.Range("A2").FormulaR1C1 = pMthYr    'the date
    
            With xls
                .Range("F4").Select  'first row
                sRow = ActiveCell.Row
    
                ActiveWindow.FreezePanes = True
                .Range("H4").Select
    
                'find the last row and move down 1 row
                Selection.End(xlDown).Select
                Selection.Offset(1, 0).Select
                eRow = ActiveCell.Row
                RowDiff = eRow - sRow
    
                'select columns H through P
                .Range(Cells(eRow, 8), Cells(eRow, 25)).Select
                'set borders
                Selection.Borders(xlDiagonalDown).LineStyle = xlNone
                Selection.Borders(xlDiagonalUp).LineStyle = xlNone
                Selection.Borders(xlEdgeLeft).LineStyle = xlNone
                With Selection.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With Selection.Borders(xlEdgeBottom)
                    .LineStyle = xlDouble
                    .ColorIndex = 0
                    .TintAndShade = 0
                    .Weight = xlThick
                End With
    
                'remove top. left and right borders
                Selection.Borders(xlEdgeRight).LineStyle = xlNone
                Selection.Borders(xlInsideVertical).LineStyle = xlNone
                Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
                'add totals formulas
                Selection.FormulaR1C1 = "=SUM(R[-" & RowDiff & "]C:R[-1]C)"
    
                .Range("A2").Select
            End With
        End If
    
        '**** End editing the worksheet *****
    
    
        ' Close the EXCEL file while saving the file, and clean up the EXCEL objects
        Set xls = Nothing
        xlw.Close True   ' close the EXCEL file and save the new data
        DoEvents
    
        Set xlw = Nothing
        Set xlx = Nothing
    
        If blnEXCEL = True Then
            xlx.Quit
        End If
    
    End Sub

  10. #10
    trevor40's Avatar
    trevor40 is offline Advanced db Manager
    Windows 7 64bit Access 2010 64bit
    Join Date
    Feb 2014
    Location
    Australia
    Posts
    402

    I did this for fun some years ago, search on my user name for controlling excel from access

    Or here is some sample code for you look through....

    created to generate excel file for employee time sheets from access data.

    It creates several sheets and summary page then edits the data, formats cells, adds program modules for added command buttons, adds conditional formatting, cell/sheet protection, cell formulas.... prety much anything you can do directly in excel you can do from access as well. With minor changes it would work for existing excel files as well.
    I had to remove some code to fit it on the page... only 50000 chr allowed!

    Sub format_sheets_now()
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim Excel_Application As Excel.Application
    Dim Excel_Workbook As Workbook
    Dim gg As String
    gg = "C:\aaa\timesheets\Employee Time Report master.xls"
    Set Excel_Workbook = Workbooks.Open(gg)
    Set Excel_Application = Excel_Workbook.Parent
    Excel_Application.Visible = True
    Excel_Workbook.Worksheets(1).Select
    Excel_Application.DisplayAlerts = False
    sdt = Format(start_date, "dd-mm-yy")
    edt = Format(End_date, "dd-mm-yy")
    Excel_Workbook.SaveAs filename:="C:\aaa\timesheets\Employee Time Report for - " & sdt & " to " & edt & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Excel_Application.DisplayAlerts = True
    'add print preview macro
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Set VBProj = Excel_Workbook.VBProject
    Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)
    Dim CodeMod As VBIDE.CodeModule
    Dim CodeMod1 As VBIDE.CodeModule
    Dim LineNum As Long
    Const DQUOTE = """"
    VBComp.Name = "preview"
    Set VBComp = VBProj.VBComponents("preview")
    Set CodeMod = VBComp.CodeModule
    With CodeMod
    LineNum = .CountOfLines + 1
    .InsertLines LineNum, "Sub print_preview"
    LineNum = LineNum + 1
    .InsertLines LineNum, "ActiveWorkbook.Worksheets.PrintPreview"
    LineNum = LineNum + 1
    .InsertLines LineNum, "End Sub"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Sub Send_Mail"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Dim OutlookApp As Object"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Dim OutlookMail As Object"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Set OutlookApp = CreateObject(" & DQUOTE & "Outlook.Application" & DQUOTE & ")"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Set OutlookMail = OutlookApp.CreateItem(0)"
    LineNum = LineNum + 1
    .InsertLines LineNum, "t = ThisWorkbook.FullName"
    LineNum = LineNum + 1
    .InsertLines LineNum, "With OutlookMail"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Application.DisplayAlerts = False"
    LineNum = LineNum + 1
    .InsertLines LineNum, "ActiveWorkbook.Save"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Application.DisplayAlerts = True"
    LineNum = LineNum + 1
    .InsertLines LineNum, ".Attachments.Add(t)"
    LineNum = LineNum + 1
    .InsertLines LineNum, ".Subject = " & DQUOTE & "Employee Time Sheets" & DQUOTE
    LineNum = LineNum + 1
    .InsertLines LineNum, ".Display"
    LineNum = LineNum + 1
    .InsertLines LineNum, "End With"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Set OutlookMail = Nothing"
    LineNum = LineNum + 1
    .InsertLines LineNum, "Set OutlookApp = Nothing"
    LineNum = LineNum + 1
    .InsertLines LineNum, "End Sub"
    End With
    Excel_Workbook.Worksheets(1).Select
    Excel_Workbook.Worksheets.Add ' Summary
    Excel_Workbook.Worksheets(1).Name = "Summary"
    'main sheet formatting here
    Excel_Application.DisplayFormulaBar = False
    Excel_Application.ActiveWindow.DisplayGridlines = False
    Excel_Application.ActiveWindow.DisplayHeadings = False
    For sheet_count = 2 To Excel_Workbook.Worksheets.Count
    Set Current_Worksheet = Excel_Workbook.Worksheets(sheet_count)
    Excel_Workbook.Worksheets(sheet_count).Select
    Current_Worksheet.Cells.Select
    With Selection
    Current_Worksheet.Cells.HorizontalAlignment = xlRight
    Current_Worksheet.Cells.Font.Name = "Times New Roman"
    End With
    Current_Worksheet.Range("A1:P1").HorizontalAlignme nt = xlCenter
    Current_Worksheet.Range("A1:P1").VerticalAlignment = xlCenter
    Current_Worksheet.Range("A1:P1").Font.Bold = True
    Current_Worksheet.Range("C:F").NumberFormat = "h:mm"
    last_cell = Current_Worksheet.Cells.SpecialCells(xlCellTypeLas tCell).Address
    rng1 = "A$2:P" & Mid(last_cell, 4, 3)
    ' SORT BY NAME IN THEN DATE IN
    Current_Worksheet.Range(rng1).Sort Key1:=Current_Worksheet.Range("A8"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    last_row = Mid(last_cell, 4, 3)
    st_date = Me.start_date
    en_date = Me.End_date
    date_count = en_date - st_date
    Current_Worksheet.Range("A2").Select
    If IsEmpty(Current_Worksheet.Range("A2").Value) Then
    Current_Worksheet.Range("A2").Value = st_date
    Else
    End If
    try_again1:
    If Current_Worksheet.Range("A2").Value > st_date Then
    Current_Worksheet.Rows("2:2").Insert Shift:=xlDown
    Current_Worksheet.Range("A2").Value = Current_Worksheet.Range("A3").Value - 1
    GoTo try_again1
    Else
    End If
    For ib = 2 To 50 'date_count + 2
    nxt_row:
    cur_cell = Current_Worksheet.Range("A" & ib).Value
    nxt_cell = Current_Worksheet.Range("A" & ib + 1).Value
    If IsEmpty(nxt_cell) Then
    GoTo done_it
    Else
    End If
    If nxt_cell - 1 = cur_cell Then
    ib = ib + 1
    GoTo nxt_row
    Else
    Current_Worksheet.Rows(ib + 1 & ":" & ib + 1).Insert Shift:=xlDown
    Current_Worksheet.Range("A" & ib + 1).Value = Current_Worksheet.Range("A" & ib).Value + 1
    End If
    Next ib
    done_it:
    try_again2:
    last_cell = Current_Worksheet.Cells.SpecialCells(xlCellTypeLas tCell).Address
    If Current_Worksheet.Range("A" & Mid(last_cell, 4, 3)).Value < en_date Then
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 1).Value = Current_Worksheet.Range("A" & Mid(last_cell, 4, 3)).Value + 1
    GoTo try_again2
    Else
    End If
    last_cell = Current_Worksheet.Cells.SpecialCells(xlCellTypeLas tCell).Address
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 1).Value = Current_Worksheet.Range("A" & Mid(last_cell, 4, 3)).Value + 1
    last_cell = Current_Worksheet.Cells.SpecialCells(xlCellTypeLas tCell).Address
    For i = 2 To Mid(last_cell, 4, 3)
    Next i
    Current_Worksheet.ListObjects("List1").TableStyle = "TableStyleMedium10"
    End With
    Current_Worksheet.Range("R1").Formula = "=Left(Q1, (Find(""_"", Q1) - 1))"
    Current_Worksheet.Range("S1").Formula = "=Len(Left(Q1,(Find(""_"", Q1))+1))"
    Current_Worksheet.Range("T1").Formula = "=MID(Q1,S1,100)"
    Current_Worksheet.Range("G1").Value = Current_Worksheet.Range("R1").Value
    Current_Worksheet.Range("L1").Value = Current_Worksheet.Range("T1").Value
    Else
    For i = 1 To Len(Excel_Workbook.Worksheets(sheet_count).Name)
    If IsNumeric(Mid(Excel_Workbook.Worksheets(sheet_coun t).Name, i, 1)) = True Then
    myNum = myNum & Mid(Excel_Workbook.Worksheets(sheet_count).Name, i, 1)
    End If
    Next i
    Current_Worksheet.Range("G1").Value = DLookup("[First Name]", "Employees", "[Code #]= " & myNum)
    Current_Worksheet.Range("L1").Value = DLookup("[Last Name]", "Employees", "[Code #]= " & myNum)
    Current_Worksheet.Range("P1").Value = DLookup("[Code #]", "Employees", "[Code #]= " & myNum)
    Current_Worksheet.Range("J2").Value = DLookup("[Employment Type]", "Employees", "[Code #]= " & myNum)
    tt2 = Format(DLookup("[Normal Start Time]", "Employees", "[Code #]= " & myNum), "H:MM" + "am/pm")
    tt3 = Format(DLookup("[Normal End Time]", "Employees", "[Code #]= " & myNum), "H:MM" + "am/pm")
    Current_Worksheet.Range("N2").Value = tt2 & " to " & tt3
    End If
    Current_Worksheet.Range("A1:E1").MergeCells = True
    Current_Worksheet.Range("A5:P5").WrapText = True
    End With
    '' sums go here
    Current_Worksheet.Range("N8:N" & Mid(last_cell, 4, 3)).Value = ""
    Current_Worksheet.Range("B8:B" & Mid(last_cell, 4, 3)).Formula = "=IF(ISBLANK($A8)," & Chr(34) & "" & Chr(34) & ",$A8)"
    Current_Worksheet.Range("G8:G" & Mid(last_cell, 4, 3)).Formula = "=IF(AND(ISBLANK(C8),ISBLANK(D8),ISBLANK(E8),ISBLA NK(F8)),5, IF(OR(ISBLANK(A8),ISBLANK(C8),ISBLANK(D8),ISBLANK( E8),ISBLANK(F8),MOD(MINUTE(C8),15)>0,MOD(MINUTE(D8 ),15)>0,MOD(MINUTE(E8),15)>0,MOD(MINUTE(F8),15)>0, (H8)<=0,(C8)>(D8),(D8)>(E8),(E8)>(F8),ISERROR(H8), ISERROR(I9),ISERROR(O8),ISERROR(P8)),1, IF(OR((C8)<0.270833333,(C8)>0.770833334),1, IF(OR((D8)<0.270833333,(D8)>0.770833334),1, IF(OR((E8)<0.270833333,(E8)>0.770833334),1, IF(OR((F8)<0.270833333,(F8)>0.770833334),1,10))))) )"
    Current_Worksheet.Range("H8:H" & Mid(last_cell, 4, 3)).Formula = "=($E8-$D8)"
    Current_Worksheet.Range("I8:I" & Mid(last_cell, 4, 3)).Formula = "=HOUR($K8)/24"
    Current_Worksheet.Range("J8:J" & Mid(last_cell, 4, 3)).Formula = "=$K8-HOUR($K8)/24"
    Current_Worksheet.Range("K8:K" & Mid(last_cell, 4, 3)).Formula = "=IF(AND((C8)<(D8),(D8)<(E8),(E8)<(F8),(F8)>(E8)), ($F8-$C8)-($E8-$D8),0)"
    Current_Worksheet.Range("M8").Formula = "=IF(OR(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ") = " & Chr(34) & "Sat" & Chr(34) & ", TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ") = " & Chr(34) & "Sun" & Chr(34) & "), 0, IF($K8*24 > 8, 8, ($K8*24)))"
    Current_Worksheet.Range("N8").Formula = "=IF(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ")=" & Chr(34) & "Sun" & Chr(34) & ",0,IF(AND(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ")=" & Chr(34) & "Sat" & Chr(34) & ",$K8*24>4),4,IF(AND(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ")=" & Chr(34) & "Sat" & Chr(34) & ",$K8*24<=4),$K8*24,IF(AND(NOT(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ")=" & Chr(34) & "Sat" & Chr(34) & "),NOT(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ")=" & Chr(34) & "Sun" & Chr(34) & ")),IF(AND($K8*24>8, $K8*24<=11), (($K8*24)-8),IF($K8*24>=11, 3,IF($K8*24<=8,$K8-$K8)))))))"
    Current_Worksheet.Range("O8").Formula = "=IF(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ")=" & Chr(34) & "Sun" & Chr(34) & ",$K8*24,IF(AND(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ") = " & Chr(34) & "Sat" & Chr(34) & ",($K8*24)-4<=0),0,IF(AND(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ") = " & Chr(34) & "Sat" & Chr(34) & ",(($K8*24)-4)>0),(($K8*24)-4),IF(AND(NOT(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ") = " & Chr(34) & "Sat" & Chr(34) & "),NOT(TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ")=" & Chr(34) & "Sun" & Chr(34) & "),$K8*24>=11),(($K8*24)-11),0))))"
    Current_Worksheet.Range("P8").Formula = "=($O8)+($N8)+($M8)"
    Current_Worksheet.Range("$M" & Mid(last_cell, 4, 3) + 2).Formula = "=SUMIF($G$8:$G$" & Mid(last_cell, 4, 3) & "," & Chr(34) & ">1" & Chr(34) & ",$M$8:$M$" & Mid(last_cell, 4, 3) & ")"
    Current_Worksheet.Range("$N" & Mid(last_cell, 4, 3) + 2).Formula = "=SUMIF($G$8:$G$" & Mid(last_cell, 4, 3) & "," & Chr(34) & ">1" & Chr(34) & ",$N$8:$N$" & Mid(last_cell, 4, 3) & ")"
    Current_Worksheet.Range("$O" & Mid(last_cell, 4, 3) + 2).Formula = "=SUMIF($G$8:$G$" & Mid(last_cell, 4, 3) & "," & Chr(34) & ">1" & Chr(34) & ",$O$8:$O$" & Mid(last_cell, 4, 3) & ")"
    Current_Worksheet.Range("$P" & Mid(last_cell, 4, 3) + 2).Formula = "=SUMIF($G$8:$G$" & Mid(last_cell, 4, 3) & "," & Chr(34) & ">1" & Chr(34) & ",$P$8:$P$" & Mid(last_cell, 4, 3) & ")"
    Excel_Workbook.Worksheets("Summary").Range("A" & 6 + sheet_count).Formula = "=" & Excel_Workbook.Worksheets(sheet_count).Name & "!P1"
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 1 & ":A" & Mid(last_cell, 4, 3) + 1).Font.Size = 10
    Set newiconset3 = Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 9).FormatConditions.AddIconSetCondition
    With Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 9).FormatConditions(1).IconCriteria(2)
    With Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 9).FormatConditions(1)
    .ShowIconOnly = True
    End With
    .Type = xlConditionValueNumber
    .Value = 0
    .Operator = 5
    .Icon = xlIconGreenCheck
    End With
    With Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 9).FormatConditions(1).IconCriteria(3)
    .Type = xlConditionValueNumber
    .Value = 1
    .Operator = 7
    .Icon = xlIconGreenCheck
    End With
    Set newiconset4 = Current_Worksheet.Range("L" & Mid(last_cell, 4, 3) + 9).FormatConditions.AddIconSetCondition
    With Current_Worksheet.Range("L" & Mid(last_cell, 4, 3) + 9).FormatConditions(1).IconCriteria(2)
    .Type = xlConditionValueNumber
    .Value = 0
    .Operator = 5
    .Icon = xlIconYellowExclamation
    End With
    With Current_Worksheet.Range("C$8:F" & Mid(last_cell, 4, 3)).FormatConditions(2).IconCriteria(3)
    .Type = xlConditionValueNumber
    .Value = 0.770833334
    .Operator = 5
    .Icon = xlIconYellowExclamation
    End With
    ' Check for time in 15 minute increments
    Current_Worksheet.Range("C8:F" & Mid(last_cell, 4, 3)).Select
    With Selection
    Current_Worksheet.Range("C8:F" & Mid(last_cell, 4, 3)).FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(MINUTE(C8:F" & Mid(last_cell, 4, 3) & "),15)>0"
    Current_Worksheet.Range("C8:F" & Mid(last_cell, 4, 3)).FormatConditions(3).Interior.Color = 49407
    End With
    'conditional formatting - text color = green for saturday and red for sunday
    For i = 8 To Mid(last_cell, 4, 3)
    Current_Worksheet.Range("A" & i & ":" & "P" & i).Select
    With Selection
    Current_Worksheet.Range("A" & i & ":" & "P" & i).FormatConditions.Add Type:=xlExpression, Formula1:="=TEXT($B" & i & "," & Chr(34) & "Ddd" & Chr(34) & ") =" & Chr(34) & "Sat" & Chr(34) & ""
    Current_Worksheet.Range("A" & i & ":" & "P" & i).FormatConditions(7).Font.Color = -16744448
    End With
    Next i
    For i = 8 To Mid(last_cell, 4, 3)
    Current_Worksheet.Range("A" & i & ":" & "P" & i).Select
    With Selection
    Current_Worksheet.Range("A" & i & ":" & "P" & i).FormatConditions.Add Type:=xlExpression, Formula1:="=TEXT($B" & i & "," & Chr(34) & "Ddd" & Chr(34) & ") =" & Chr(34) & "Sun" & Chr(34) & ""
    Current_Worksheet.Range("A" & i & ":" & "P" & i).FormatConditions(8).Font.Color = 255
    End With
    Next i
    Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 3).Value = "Overtime time will be paid after 8 Hrs ordinary time worked Monday to Friday"
    Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 3 & ":P" & Mid(last_cell, 4, 3) + 3).Merge
    Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 3).HorizontalAlignment = xlCenter
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 5).Value = "Employee's Signature:........................................ .................................................. ............... Date:.........................................."
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 5).RowHeight = 25
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 5 & ":L" & Mid(last_cell, 4, 3) + 5).MergeCells = True
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 5).HorizontalAlignment = xlLeft
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 6).Value = "Supervisor/Managers Signature:........................................ ................................................ Date:.........................................."
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 6).RowHeight = 40
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 6).HorizontalAlignment = xlLeft
    Current_Worksheet.Range("A3:F4").MergeCells = True
    Current_Worksheet.Range("A3").Value = " Enter times in 24 hour format.(7:00=7am 13:00=1pm)" & vbCrLf & "Only valid times between 6:30AM and 6:30PM Accepted"
    Current_Worksheet.Range("B" & Mid(last_cell, 4, 3) + 8 & ":N" & Mid(last_cell, 4, 3) + 8).Borders(xlEdgeBottom).LineStyle = xlContinuous
    '' set time cell reference
    time_val = TimeValue("06:30")
    For ti = 104 To 152
    Current_Worksheet.Range("A" & ti).Value = time_val
    time_val = time_val + TimeValue("0:15")
    Next ti
    Current_Worksheet.Range("A104:A152").NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Current_Worksheet.Range("A104:A152").Font.Color = 16777215
    ' validate times
    With Current_Worksheet.Range("C8:F" & Mid(last_cell, 4, 3)).Cells.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=$A$104:$A$152"
    .IgnoreBlank = True
    .InCellDropdown = True
    .ErrorMessage = "Time entered must be multples of 15 minutes" & vbCrLf & " Between 6:30AM and 6:30PM"
    .ShowInput = True
    .ShowError = True
    End With
    ' validate dates
    With Current_Worksheet.Range("A8:A" & Mid(last_cell, 4, 3)).Cells.Validation
    .Delete
    .Add Type:=xlValidateDate, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="1/1/2010", Formula2:="1/1/2050"
    .IgnoreBlank = True
    .InCellDropdown = False
    .ShowInput = True
    .ShowError = True
    End With
    Current_Worksheet.Range("B:B").HorizontalAlignment = xlLeft
    Current_Worksheet.Range("A8:A" & Mid(last_cell, 4, 3)).NumberFormat = "dd/mm/yy"
    Current_Worksheet.Range("B8:B" & Mid(last_cell, 4, 3)).Font.Italic = True
    Current_Worksheet.Range("B8" & ":B" & Mid(last_cell, 4, 3)).NumberFormat = "Ddd"
    'set footer rows
    Select Case Mid(last_cell, 4, 3)
    Case Is <= 22
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 5).RowHeight = 30 + (21 - Mid(last_cell, 4, 3)) * 15.6
    Case Is > 22
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 5).RowHeight = 30
    Current_Worksheet.Range("A15").Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
    Case Else
    End Select
    Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 11 & ":P" & Mid(last_cell, 4, 3) + 11).Borders(xlEdgeBottom).LineStyle = xlContinuous
    ' text boxes - index, left, top, wide, high
    '' top
    Current_Worksheet.Shapes.AddTextbox(1, 760, 20, 240, 100).TextFrame.Characters.Text = "This form must be completed and returned to the Manager In Charge" & Chr(13) & "On a fortighly basis, Recurring calendar invitations will be sent Fortnightly."
    Current_Worksheet.Shapes(1).Fill.ForeColor.RGB = RGB(242, 220, 219)
    Current_Worksheet.Shapes(1).TextFrame2.TextRange.F ont.Size = 14
    Current_Worksheet.Shapes(1).TextFrame2.TextRange.F ont.Name = "Times New Roman"
    '' middle
    Current_Worksheet.Shapes.AddTextbox(1, 760, 140, 240, 96).TextFrame.Characters.Text = "Managers need to submit an electronic copy of the payroll Summary and a physical copy of the Casual time sheet with required signatures." & Chr(13) & " (Every second Tuesday by 4.00pm)"
    Current_Worksheet.Shapes(2).Fill.ForeColor.RGB = RGB(242, 220, 219)
    Current_Worksheet.Shapes(2).TextFrame2.TextRange.F ont.Size = 14
    Current_Worksheet.Shapes(2).TextFrame2.TextRange.F ont.Name = "Times New Roman"
    '' bottom
    Current_Worksheet.Shapes.AddTextbox(1, 760, 255, 240, 116).TextFrame.Characters.Text = "Changes can only be made to the Time cells in columns C to F, and Employee details. When all cells have been filled with valid Times and Employee details, the results will be displayed, If a day was not worked leave the times blank."
    Current_Worksheet.Shapes(3).Fill.ForeColor.RGB = RGB(242, 220, 219)
    Current_Worksheet.Shapes(3).TextFrame2.TextRange.F ont.Size = 14
    Current_Worksheet.Shapes(3).TextFrame2.TextRange.F ont.Name = "Times New Roman"
    'set tab colors
    Current_Worksheet.Range("8:8").Select
    Excel_Application.ActiveWindow.DisplayGridlines = False
    Excel_Application.ActiveWindow.FreezePanes = True
    With Current_Worksheet.PageSetup
    .PaperSize = xlPaperA4
    .PrintTitleRows = "$1:$7"
    .PrintArea = ("$A$1:$P$" & Mid(last_cell, 4, 3) + 11)
    .CenterHorizontally = True
    .Zoom = 100
    .CenterFooter = "Page &P of &N"
    .CenterHeader = ""
    .LeftMargin = 0
    .RightMargin = 0
    .TopMargin = 0
    .BottomMargin = 2
    .FooterMargin = 0
    .Orientation = xlLandscape
    End With
    Current_Worksheet.Range("W1").Formula = "=COUNTIF(G8:G" & Mid(last_cell, 4, 3) & "," & Chr(34) & "<5" & Chr(34) & ")"
    If Current_Worksheet.Range("W1").Value < 1 Then
    Current_Worksheet.Tab.Color = 3669844
    Else
    Current_Worksheet.Tab.Color = 5987327
    End If
    Current_Worksheet.Range("W1").Font.Color = 16777215
    Excel_Workbook.Worksheets("Summary").Range("B1").F ont.Color = 16777215
    ' add sheet change macro
    Dim oVBproj As VBIDE.VBProject
    Dim oVBcomp As VBIDE.VBComponent
    Dim oVBmod As VBIDE.CodeModule '
    Dim lLine As Single
    Set ws = Current_Worksheet
    Set oVBproj = Excel_Workbook.VBProject
    Set oVBcomp = oVBproj.VBComponents(ws.CodeName)
    Set oVBmod = oVBcomp.CodeModule
    With oVBmod
    lLine = .CreateEventProc("Change", "Worksheet") + 1
    .InsertLines lLine, "End If"
    .InsertLines lLine, " Application.EnableEvents = True"
    .InsertLines lLine, " Target.select"
    .InsertLines lLine, " Target.Value = """
    .InsertLines lLine, " Application.EnableEvents = False"
    .InsertLines lLine, " MsgBox " & """Worksheet Tab Names based on Employee name on sheet. There is already a sheet with that name."""
    .InsertLines lLine, " Else"
    .InsertLines lLine, " ActiveSheet.Name = Cells(1, 7)" & " & " & """, """ & " & " & "Cells(1, 12)"
    .InsertLines lLine, " If bln = False Then"
    .InsertLines lLine, " End If"
    .InsertLines lLine, " err.Clear"
    .InsertLines lLine, " bln = False"
    .InsertLines lLine, " Else"
    .InsertLines lLine, " bln = True"
    .InsertLines lLine, " If Not wks Is Nothing Then"
    .InsertLines lLine, " On Error Resume Next"
    .InsertLines lLine, " Set wks = ActiveWorkbook.Worksheets(strSheetName)"
    .InsertLines lLine, " On Error Resume Next"
    .InsertLines lLine, " strSheetName = Trim(Target.Value)"
    .InsertLines lLine, " Dim strSheetName As String, wks As Worksheet, bln As Boolean"
    .InsertLines lLine, " Next i"
    .InsertLines lLine, " End If"
    .InsertLines lLine, " Exit Sub"
    .InsertLines lLine, " Application.EnableEvents = True"
    .InsertLines lLine, " Target.select"
    .InsertLines lLine, " Target.Value = """
    .InsertLines lLine, " Application.EnableEvents = False"
    .InsertLines lLine, " MsgBox " & """Worksheet Tab Names based on Employee name on sheet. Special characters not allowed in sheet names."""
    .InsertLines lLine, " If InStr(Target.Value, (IllegalCharacter(i))) > 0 Then"
    .InsertLines lLine, " For i = 1 To 7"
    .InsertLines lLine, " IllegalCharacter(7) = " & """:"""
    .InsertLines lLine, " IllegalCharacter(6) = " & """?"""
    .InsertLines lLine, " IllegalCharacter(5) = " & """*"""
    .InsertLines lLine, " IllegalCharacter(4) = " & """]"""
    .InsertLines lLine, " IllegalCharacter(3) = " & """["""
    .InsertLines lLine, " IllegalCharacter(2) = " & """"""
    .InsertLines lLine, " IllegalCharacter(1) = " & """/"""
    .InsertLines lLine, " Dim IllegalCharacter(1 To 7) As String, i As Integer"
    .InsertLines lLine, " End If"
    .InsertLines lLine, " Exit Sub"
    .InsertLines lLine, " Application.EnableEvents = True"
    .InsertLines lLine, " Target.select"
    .InsertLines lLine, " Target.Value = """
    .InsertLines lLine, " Application.EnableEvents = False"
    .InsertLines lLine, " MsgBox " & """Worksheet Tab Names based on Employee name on sheet. Worksheet tab names cannot be greater than 31 characters in length."""
    .InsertLines lLine, " If Len(Target.Value) > 31 Then"
    .InsertLines lLine, " If IsEmpty(Target) Then Exit Sub"
    .InsertLines lLine, " If Target.Address <>" & """$G$1"" And Target.Address <>" & """$L$1"" Then Exit Sub"
    .InsertLines lLine, "End If"
    .InsertLines lLine, " Worksheets(1).Tab.color = 5987327"
    .InsertLines lLine, "Else"
    .InsertLines lLine, " WorkSheets(1).Tab.color = 3669844"
    .InsertLines lLine, "If workSheets(1).Cells(1, 2).Value < 1 then"
    .InsertLines lLine, "End IF"
    .InsertLines lLine, " ActiveSheet.Tab.color = 5987327"
    .InsertLines lLine, "Else"
    .InsertLines lLine, " ActiveSheet.Tab.color = 3669844"
    .InsertLines lLine, "If Cells(1, 23).Value < 1 Then"
    .InsertLines lLine, "On Error Resume Next"
    End With
    Current_Worksheet.Range("J2:K2").MergeCells = True
    Current_Worksheet.Range("N2:P2").MergeCells = True
    Current_Worksheet.Range("AB1").Value = "Casual"
    Current_Worksheet.Range("AB2").Value = "Full time"
    Current_Worksheet.Range("AA1").Value = "6.30am to 2.30pm"
    Current_Worksheet.Range("AA2").Value = "6.45am to 2.45pm"
    Current_Worksheet.Range("AA3").Value = "7.00am to 3.00pm"
    Current_Worksheet.Range("AA4").Value = "7.15am to 3.15pm"
    Current_Worksheet.Range("AA5").Value = "7.30am to 3.30pm"
    Current_Worksheet.Range("AA6").Value = "7.45am to 3.45pm"
    Current_Worksheet.Range("AA7").Value = "8.00am to 4.00pm"
    Current_Worksheet.Range("AA8").Value = "8.15am to 4.15pm"
    Current_Worksheet.Range("AA9").Value = "8.30am to 4.30pm"
    Current_Worksheet.Range("AA10").Value = "8.45am to 4.45pm"
    Current_Worksheet.Range("AA11").Value = "9.00am to 5.00pm"
    Current_Worksheet.Range("AA12").Value = "9.15am to 5.15pm"
    Current_Worksheet.Range("AA13").Value = "9.30am to 5.30pm"
    Current_Worksheet.Range("AA14").Value = "9.45am to 5.45pm"
    Current_Worksheet.Range("AA15").Value = "10.00am to 6.00pm"
    Current_Worksheet.Range("AA16").Value = "10.15am to 6.15pm"
    Current_Worksheet.Range("AA17").Value = "10.30am to 6.30pm"
    Current_Worksheet.Range("AA1:AB17").Font.Color = 16777215
    With Current_Worksheet.Range("J2").Cells.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=$AB$1:$AB$2"
    .IgnoreBlank = True
    .InCellDropdown = True
    .ErrorMessage = "Only Casual or FullTime may be entered."
    .ShowError = True
    End With
    With Current_Worksheet.Range("N2").Cells.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=$AA$1:$AA$17"
    .IgnoreBlank = True
    .InCellDropdown = True
    .ErrorMessage = "Time entered must be multples of 15 minutes" & vbCrLf & " Between 6:30AM and 6:30PM"
    .ShowError = True
    End With
    '' rename sheet
    Current_Worksheet.Name = Current_Worksheet.Range("L1").Value & ", " & Current_Worksheet.Range("G1").Value
    Excel_Application.VBE.MainWindow.Visible = False
    Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 6).Select
    Current_Worksheet.Pictures.Insert("c:\aaa\logo.png ").Select ' from my desktop, works fine
    With Selection
    .ShapeRange.ScaleWidth 0.3, msoFalse, msoScaleFromTopLeft
    .ShapeRange.IncrementTop -22
    .ShapeRange.IncrementLeft -22
    End With
    Current_Worksheet.Range("G1").Select
    'Protect worksheet cells
    Current_Worksheet.Cells.Locked = True
    Current_Worksheet.Range("G1:J1").Locked = False
    Current_Worksheet.Range("L1:N1").Locked = False
    Current_Worksheet.Range("P1").Locked = False
    Current_Worksheet.Range("J2:K2").Locked = False
    Current_Worksheet.Range("N2:P2").Locked = False
    Current_Worksheet.Range("J4:L4").Locked = False
    Current_Worksheet.Range("N4:O4").Locked = False
    Current_Worksheet.Range("C8:F" & Mid(last_cell, 4, 3)).Locked = False
    Current_Worksheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="1"
    Current_Worksheet.EnableSelection = xlUnlockedCells
    DoEvents
    Next sheet_count
    Excel_Workbook.Worksheets(1).Select
    Excel_Application.DisplayFormulaBar = False
    Excel_Application.ActiveWindow.DisplayGridlines = False
    Excel_Application.ActiveWindow.DisplayHeadings = False
    For x = 2 To Excel_Workbook.Worksheets.Count
    ws_name = ws_name + "'" + Excel_Workbook.Worksheets(x).Name + "'" + "!$W$1+"
    Next
    name_ws = Left(ws_name, Len(ws_name) - 1)
    Excel_Workbook.Worksheets(1).Range("B1").Value = "=" & name_ws
    If Excel_Workbook.Worksheets(1).Range("B1").Value < 1 Then
    Excel_Workbook.Worksheets("Summary").Tab.Color = 3669844
    Else
    Excel_Workbook.Worksheets("Summary").Tab.Color = 5987327
    End If
    Excel_Workbook.Worksheets("Summary").Cells.Font.Na me = "Times New Roman"
    Excel_Workbook.Worksheets("Summary").Range("D2:L2" ).Borders(xlEdgeBottom).LineStyle = xlContinuous
    Excel_Workbook.Worksheets("Summary").Range("D2:L2" ).Font.Size = 20
    Excel_Workbook.Worksheets("Summary").Range("D2:L2" ).Merge
    Excel_Workbook.Worksheets("Summary").Range("D2").V alue = "Employee Timesheets Pay Period " & Format(sdt, "dd-mmm-yy") & " to " & Format(edt, "dd-mmm-yy")
    Excel_Workbook.Worksheets("Summary").Range("D2").H orizontalAlignment = xlCenter
    Excel_Workbook.Worksheets("Summary").Range("A7").V alue = "Payroll Code"
    Excel_Workbook.Worksheets("Summary").Range("B7").V alue = "Employee Name"
    Excel_Workbook.Worksheets("Summary").Range("C7").V alue = "Type"
    Excel_Workbook.Worksheets("Summary").Range("D7").V alue = "Normal Hours"
    Excel_Workbook.Worksheets("Summary").Range("E7").V alue = "Sat Hours"
    Excel_Workbook.Worksheets("Summary").Range("F7").V alue = "Sun Hours"
    Excel_Workbook.Worksheets("Summary").Range("G7").V alue = "O/time 1.5"
    Excel_Workbook.Worksheets("Summary").Range("H7").V alue = "O/time" & vbLf & "2"
    Excel_Workbook.Worksheets("Summary").Range("I7").V alue = "Public Holiday"
    Excel_Workbook.Worksheets("Summary").Range("J7").V alue = "Hours Worked"
    Excel_Workbook.Worksheets("Summary").Range("K7").V alue = "Shifts Worked"
    Excel_Workbook.Worksheets("Summary").Range("L7").V alue = "Notes"
    Excel_Workbook.Worksheets("Summary").Range("A7:L7" ).WrapText = True
    Excel_Workbook.Worksheets("Summary").Range("A7:L7" ).HorizontalAlignment = xlCenter
    Excel_Workbook.Worksheets("Summary").Range("A7:L7" ).Borders(xlEdgeBottom).LineStyle = xlContinuous
    last_cell1 = Excel_Workbook.Worksheets("Summary").Cells.Special Cells(xlCellTypeLastCell).Address
    R_cnt = Mid(last_cell1, 4, 3)
    ch_k = 0
    'get list of names
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("Casual employees")
    With rs
    .MoveFirst
    Do While Not .EOF
    fn = rs.Fields("First Name")
    Ln = rs.Fields("Last Name")
    bc = rs.Fields("code #")
    es = rs.Fields("Employment Type")
    For i = 8 To R_cnt
    rg = "A" & i
    If bc = Excel_Workbook.Worksheets("Summary").Range(rg).Val ue Then
    ch_k = 1
    End If
    Next i
    If ch_k = 1 Then
    Else
    Excel_Workbook.Worksheets("Summary").Range("A" & Mid(last_cell1, 4, 3) + 1).Value = bc
    Excel_Workbook.Worksheets("Summary").Range("B" & Mid(last_cell1, 4, 3) + 1).Value = Ln & ", " & fn
    Excel_Workbook.Worksheets("Summary").Range("C" & Mid(last_cell1, 4, 3) + 1).Value = es
    Excel_Workbook.Worksheets("Summary").Range("J" & Mid(last_cell1, 4, 3) + 1).Formula = "=SUM($D" & Mid(last_cell1, 4, 3) + 1 & ":$I" & Mid(last_cell1, 4, 3) + 1 & ")"
    last_cell1 = Excel_Workbook.Worksheets("Summary").Cells.Special Cells(xlCellTypeLastCell).Address
    End If
    ch_k = 0
    .MoveNext
    Loop
    End With
    Excel_Workbook.Worksheets("Summary").Range("A7:A" & Mid(last_cell1, 4, 3)).HorizontalAlignment = xlCenter
    Excel_Workbook.Worksheets("Summary").Range("7:7"). RowHeight = 31.5
    Excel_Workbook.Worksheets("Summary").Range("A8:L" & Mid(last_cell1, 4, 3)).Font.Size = 12
    Excel_Workbook.Worksheets("Summary").Range("D" & Mid(last_cell1, 4, 3) + 4).Value = "Sheet Tab Colors"
    Excel_Workbook.Worksheets("Summary").Range("D" & Mid(last_cell1, 4, 3) + 4 & ":K" & Mid(last_cell1, 4, 3) + 4).MergeCells = True
    Excel_Workbook.Worksheets("Summary").Range("D" & Mid(last_cell1, 4, 3) + 4 & ":K" & Mid(last_cell1, 4, 3) + 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
    Excel_Workbook.Worksheets("Summary").Range("D" & Mid(last_cell1, 4, 3) + 4 & ":K" & Mid(last_cell1, 4, 3) + 4).HorizontalAlignment = xlCenter
    Excel_Workbook.Worksheets("Summary").Range("D" & Mid(last_cell1, 4, 3) + 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
    Excel_Workbook.Worksheets("Summary").Range("E" & Mid(last_cell1, 4, 3) + 5).Value = "Summary"
    Excel_Workbook.Worksheets("Summary").Range("E" & Mid(last_cell1, 4, 3) + 6).Value = "Employee Tabs"
    Excel_Workbook.Worksheets("Summary").Range("E" & Mid(last_cell1, 4, 3) + 6 & ":F" & Mid(last_cell1, 4, 3) + 7).MergeCells = True
    Excel_Workbook.Worksheets("Summary").Range("E" & Mid(last_cell1, 4, 3) + 6 & ":F" & Mid(last_cell1, 4, 3) + 7).VerticalAlignment = xlCenter
    Excel_Workbook.Worksheets("Summary").Range("G" & Mid(last_cell1, 4, 3) + 5).Value = "Green = Correct Data"
    Excel_Workbook.Worksheets("Summary").Range("I" & Mid(last_cell1, 4, 3) + 5).Value = "Red = Incorrect Data"
    Excel_Workbook.Worksheets("Summary").Range("G" & Mid(last_cell1, 4, 3) + 6).Value = "Green = All Employee Sheets Updated Correctly"
    Excel_Workbook.Worksheets("Summary").Range("G" & Mid(last_cell1, 4, 3) + 7).Value = "Red = Not all Employee Sheets Updated Correctly"
    Excel_Workbook.Worksheets("Summary").Range("G" & Mid(last_cell1, 4, 3) + 5).Characters(Start:=1, Length:=5).Font.Color = -11489280
    Excel_Workbook.Worksheets("Summary").Range("I" & Mid(last_cell1, 4, 3) + 5).Characters(Start:=1, Length:=3).Font.Color = -16776961
    Excel_Workbook.Worksheets("Summary").Range("G" & Mid(last_cell1, 4, 3) + 6).Characters(Start:=1, Length:=5).Font.Color = -11489280
    Excel_Workbook.Worksheets("Summary").Range("G" & Mid(last_cell1, 4, 3) + 7).Characters(Start:=1, Length:=3).Font.Color = -16776961
    Excel_Workbook.Worksheets("Summary").Range("A$7:L" & Mid(last_cell1, 4, 3)).Select
    With Selection
    Excel_Workbook.Worksheets("Summary").ListObjects.A dd(xlSrcRange, , xlYes, xlYes).Name = "List1"
    Excel_Workbook.Worksheets("Summary").ListObjects(" List1").TableStyle = "TableStyleMedium10"
    End With
    Excel_Workbook.Worksheets("Summary").Range("D" & Mid(last_cell1, 4, 3) + 2).Formula = "=SUM($D8:$D" & Mid(last_cell1, 4, 3) & ")"
    Excel_Workbook.Worksheets("Summary").Range("E" & Mid(last_cell1, 4, 3) + 2).Formula = "=SUM($E8:$E" & Mid(last_cell1, 4, 3) & ")"
    Excel_Workbook.Worksheets("Summary").Range("F" & Mid(last_cell1, 4, 3) + 2).Formula = "=SUM($F8:$F" & Mid(last_cell1, 4, 3) & ")"
    Excel_Workbook.Worksheets("Summary").Range("G" & Mid(last_cell1, 4, 3) + 2).Formula = "=SUM($G8:$G" & Mid(last_cell1, 4, 3) & ")"
    Excel_Workbook.Worksheets("Summary").Range("H" & Mid(last_cell1, 4, 3) + 2).Formula = "=SUM($H8:$H" & Mid(last_cell1, 4, 3) & ")"
    Excel_Workbook.Worksheets("Summary").Range("I" & Mid(last_cell1, 4, 3) + 2).Formula = "=SUM($I8:$I" & Mid(last_cell1, 4, 3) & ")"
    Excel_Workbook.Worksheets("Summary").Range("J" & Mid(last_cell1, 4, 3) + 2).Formula = "=SUM($J8:$J" & Mid(last_cell1, 4, 3) & ")"
    Excel_Workbook.Worksheets("Summary").Range("C" & Mid(last_cell1, 4, 3) + 2 & ":J" & Mid(last_cell1, 4, 3) + 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
    Excel_Workbook.Worksheets("Summary").Range("C" & Mid(last_cell1, 4, 3) + 2).Value = "Totals"
    Excel_Workbook.Worksheets("Summary").Range("C" & Mid(last_cell1, 4, 3) + 2 & ":J" & Mid(last_cell1, 4, 3) + 2).Font.Bold = True
    Excel_Workbook.Worksheets("Summary").Rows("1:1").D elete
    Excel_Workbook.Worksheets("Summary").Rows("3:3").D elete
    Excel_Workbook.Worksheets("Summary").Range("A1").S elect
    Excel_Workbook.Worksheets("Summary").Pictures.Inse rt("c:\aaa\logo.png").Select ' from my desktop, works fine
    With Selection
    .ShapeRange.ScaleWidth 0.27, msoFalse, msoScaleFromTopLeft
    .ShapeRange.IncrementTop 0
    .ShapeRange.IncrementLeft 25
    End With

    Excel_Workbook.Worksheets("Summary").Range("G3").V alue = "Please advise of any new staff or staff who have resigned"
    Excel_Workbook.Worksheets("Summary").Range("A:A"). ColumnWidth = 7
    Excel_Workbook.Worksheets("Summary").Range("B:B"). ColumnWidth = 33
    Excel_Workbook.Worksheets("Summary").Range("C:C"). ColumnWidth = 8.11
    Excel_Workbook.Worksheets("Summary").Range("D").ColumnWidth = 8
    Excel_Workbook.Worksheets("Summary").Range("E:E"). ColumnWidth = 7
    Excel_Workbook.Worksheets("Summary").Range("F:F"). ColumnWidth = 7
    Excel_Workbook.Worksheets("Summary").Range("G:G"). ColumnWidth = 7
    Excel_Workbook.Worksheets("Summary").Range("H:H"). ColumnWidth = 7
    Excel_Workbook.Worksheets("Summary").Range("I:I"). ColumnWidth = 9
    Excel_Workbook.Worksheets("Summary").Range("J:J"). ColumnWidth = 8
    Excel_Workbook.Worksheets("Summary").Range("K:K"). ColumnWidth = 9
    Excel_Workbook.Worksheets("Summary").Range("L:L"). ColumnWidth = 27
    ' text boxes - index, left, top, wide, high
    Excel_Workbook.Worksheets("Summary").Shapes.AddTex tbox(1, 800, 135, 230, 60).TextFrame.Characters.Text = "This Summary can be deleted if" & Chr(13) & " not required. This will not effect any" & Chr(13) & " Cell Formulas on Employee Sheets." ' " & Chr(13) & "
    Excel_Workbook.Worksheets("Summary").Shapes(2).Fil l.ForeColor.RGB = RGB(242, 220, 219)
    Excel_Workbook.Worksheets("Summary").Shapes(2).Tex tFrame2.TextRange.Font.Size = 14
    Excel_Workbook.Worksheets("Summary").Shapes(2).Tex tFrame2.TextRange.Font.Name = "Times New Roman"
    Excel_Workbook.Worksheets("Summary").Shapes.AddTex tbox(1, 800, 205, 230, 60).TextFrame.Characters.Text = "Individual sheet names are based on" & Chr(13) & " the employee name on each sheet."
    Excel_Workbook.Worksheets("Summary").Shapes(3).Fil l.ForeColor.RGB = RGB(242, 220, 219)
    Excel_Workbook.Worksheets("Summary").Shapes(3).Tex tFrame2.TextRange.Font.Size = 14
    Excel_Workbook.Worksheets("Summary").Shapes(3).Tex tFrame2.TextRange.Font.Name = "Times New Roman"
    Excel_Workbook.Worksheets("Summary").Shapes.AddTex tbox(1, 800, 275, 230, 130).TextFrame.Characters.Text = "The layout of the column headings is for the Print View of the workbook, they may not show completley while viewing the worksheet in edit mode. The column widths cannot be changed while the worksheet is protected."
    Excel_Workbook.Worksheets("Summary").Shapes(4).Fil l.ForeColor.RGB = RGB(242, 220, 219)
    Excel_Workbook.Worksheets("Summary").Shapes(4).Tex tFrame2.TextRange.Font.Size = 14
    Excel_Workbook.Worksheets("Summary").Shapes(4).Tex tFrame2.TextRange.Font.Name = "Times New Roman"
    Excel_Workbook.Worksheets("Summary").Buttons.Add(8 00, 5, 230, 40).Select
    Excel_Workbook.Worksheets("Summary").Buttons(1).Se lect
    Excel_Workbook.Worksheets("Summary").Buttons(1).Ch aracters.Text = "Print Preview"
    Excel_Workbook.Worksheets("Summary").Buttons(1).On Action = "print_preview"
    Excel_Workbook.Worksheets("Summary").Buttons(1).Fo nt.Name = "Times New Roman"
    Excel_Workbook.Worksheets("Summary").Buttons(1).Fo nt.Size = 34
    Excel_Workbook.Worksheets("Summary").Buttons.Add(8 00, 55, 230, 40).Select
    Excel_Workbook.Worksheets("Summary").Buttons(2).Se lect
    Excel_Workbook.Worksheets("Summary").Buttons(2).Ch aracters.Text = "Save & Email"
    Excel_Workbook.Worksheets("Summary").Buttons(2).On Action = "Send_Mail"
    Excel_Workbook.Worksheets("Summary").Buttons(2).Fo nt.Name = "Times New Roman"
    Excel_Workbook.Worksheets("Summary").Buttons(2).Fo nt.Size = 34
    With Excel_Workbook.Worksheets("Summary").Range("A6:L" & Mid(last_cell1, 4, 3) - 2).Select
    Selection.Borders(xlEdgeLeft).Weight = xlThin
    Selection.Borders(xlEdgeTop).Weight = xlThin
    Selection.Borders(xlEdgeBottom).Weight = xlThin
    Selection.Borders(xlEdgeRight).Weight = xlThin
    Selection.Borders(xlInsideVertical).Weight = xlHairline
    Selection.Borders(xlInsideHorizontal).Weight = xlHairline
    End With
    With Excel_Workbook.Worksheets("Summary").Range("A5:L5" ).Select ' Range("List1_1[#All]").Select
    Selection.Borders(xlEdgeLeft).Weight = xlThin
    Selection.Borders(xlEdgeTop).Weight = xlThin
    Selection.Borders(xlEdgeRight).Weight = xlThin
    End With
    Excel_Workbook.Worksheets("Summary").Range("6:6"). Select
    Excel_Application.ActiveWindow.FreezePanes = True
    Excel_Application.ActiveWindow.TabRatio = 0.75
    With Excel_Workbook.Worksheets("Summary").PageSetup
    .PaperSize = xlPaperA4
    .PrintTitleRows = "$1:$5"
    .CenterHorizontally = True
    .Zoom = 100
    .CenterFooter = "Page &P of &N"
    .CenterHeader = ""
    .LeftMargin = 0
    .RightMargin = 0
    .TopMargin = 0
    .BottomMargin = 10
    .FooterMargin = 0
    .Orientation = xlLandscape
    .PrintArea = ("$A$1:$L$" & Mid(last_cell1, 4, 3))
    End With
    'Protect worksheet cells
    Excel_Workbook.Worksheets("Summary").Cells.Locked = True
    Excel_Workbook.Worksheets("Summary").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="finance1"
    Excel_Workbook.Worksheets("Summary").EnableSelecti on = xlUnlockedCells
    Excel_Application.DisplayAlerts = False
    Excel_Workbook.SaveAs filename:="C:\aaa\timesheets\Employee Time Report for - " & sdt & " to " & edt & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    t = Len(Dir("C:\timesheet backups"))
    If t = 0 Then
    Else
    Excel_Workbook.SaveAs filename:="C:\timesheet backups\Employee Time Report for - " & sdt & " to " & edt & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    End If
    Excel_Application.DisplayAlerts = True
    Kill "C:\aaa\timesheets\Employee Time Report Master.xls"
    End Sub

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Export Query Results to Excel Template
    By laterdater in forum Macros
    Replies: 2
    Last Post: 09-25-2015, 11:20 AM
  2. Replies: 3
    Last Post: 07-31-2014, 01:08 AM
  3. Replies: 13
    Last Post: 12-12-2013, 07:22 PM
  4. Replies: 1
    Last Post: 10-28-2013, 12:32 PM
  5. Remove/Ignore beginning of text file on import
    By Insyderznf in forum Import/Export Data
    Replies: 9
    Last Post: 10-24-2011, 04:56 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums