Results 1 to 6 of 6
  1. #1
    priceman31 is offline Novice
    Windows 7 32bit Access 2010 32bit
    Join Date
    Oct 2017
    Location
    Tampa, FL
    Posts
    7

    Trying Unsuccessfully, to export query results to Existing Sheet in Existing Excel Workbook

    I have been try to use the DoCmd.TransferSpreadhseet acExport to export the results of a query to an existing Workbook. I have tried naming the sheet in the range criteria part of the code
    but instead of sending the results to the named spreadsheet it creates another spreadsheet with the same name with a 1 at the end. Below is the code I'm using. The name of the sheet is Employees_by_Supervisor. I'm a little unsure why it's not working. Any assistance or guidance would be greatly appreciated.



    Dim ExportFileName As String
    Dim TemplatePath As String


    TemplatePath = "C:\Program Files\Company\email\Admin\Emergency Contact Responses.xlsb"
    ExportPath = "C:\Program Files\Compan\email\Data\ERD\Emergency Responses for " & Forms!Form1!SN & ".xlsb"

    FileCopy TemplatePath, ExportPath

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "Qry_ECR", ExportPath, True, "Employees_by_Supervisor"

  2. #2
    ranman256's Avatar
    ranman256 is offline VIP
    Windows Vista Access 2010 32bit
    Join Date
    Apr 2014
    Location
    Kentucky
    Posts
    9,521
    Dont use .xlsb,
    use .xls, or .xlsx

  3. #3
    priceman31 is offline Novice
    Windows 7 32bit Access 2010 32bit
    Join Date
    Oct 2017
    Location
    Tampa, FL
    Posts
    7
    Quote Originally Posted by ranman256 View Post
    Dont use .xlsb,
    use .xls, or .xlsx
    I tried using .xls and xlsx...same result. Still creating separate sheet.

  4. #4
    ranman256's Avatar
    ranman256 is offline VIP
    Windows Vista Access 2010 32bit
    Join Date
    Apr 2014
    Location
    Kentucky
    Posts
    9,521
    The last param always writes to the sheet specified. It does not create another.

  5. #5
    trevor40's Avatar
    trevor40 is offline Advanced db Manager
    Windows 7 64bit Access 2010 64bit
    Join Date
    Feb 2014
    Location
    Australia
    Posts
    402
    Here's a snipet from something i created a long time ago, hope it helps, it was used to create a time sheet, the part you need is marked in red, it also gives you a good idea of how/what can be controlled from Access... everything!. there was an update i did to this that added command buttons and vba macros to excel as well.

    Code:
    Private Sub Command54_Click()
        Dim strPath As String
        Dim rst As DAO.Recordset
        Dim stDocName As String
        Dim Excel_Application As Excel.Application
        Dim Excel_Workbook As Excel.Workbook
        Dim Current_Worksheet As Excel.Worksheet
        Dim Data_Range
        Dim Worksheet_Name
        Dim rs As Recordset
        Dim headercell, firstcellref, nextname, FirstName, linecount, nextcellref, bb, CC, dd, rangestart, rangeend, Mt
        Dim aa As Integer
        Dim db As DAO.Database
        Dim rstActual As DAO.Recordset
        Set db = CurrentDb
        DoCmd.RunSQL "DELETE * FROM manual_sheet"
        Set rstActual = db.OpenRecordset("manual_sheet")
        t = Forms![main menu].start_date
        For i = 1 To InputBox("Enter number of lines required", "Manual Time Sheet creation")
            Set rstActual = db.OpenRecordset("manual_sheet", dbOpenDynaset)
            rstActual.AddNew
            rstActual!new_date = t
            rstActual.Update
            rstActual.Close
            t = t + 1
        Next i
        nRecords = DCount("*", "Employee Time Report Output with lunch for manual sheet")
        If nRecords = 0 Then
            MsgBox "No data for selected period, change report dates and try agian.", vbOKOnly, "Error"
            Exit Sub
        End If
    
        sdt = Format(start_date, "dd-mm-yy")
        edt = Format(End_date, "dd-mm-yy")
        If IsNull(Me.employee_selected) Then
            t = MsgBox("Please select an Employee First", vbOKOnly, "Missing Information")
            Exit Sub
        Else
            xx = Me.employee_selected
            fn = DLookup("[first name]", "[employees]", "[barcode] = " & Me.employee_selected)
            Ln = DLookup("[last name]", "[employees]", "[barcode] = " & Me.employee_selected)
            ns = DLookup("[Normal Start Time]", "[employees]", "[barcode] = " & Me.employee_selected)
            ne = DLookup("[Normal End Time]", "[employees]", "[barcode] = " & Me.employee_selected)
        End If
        gg = "C:\aaa\Employee Time Report for - " & fn & ", " & Ln & ", " & sdt & " to " & edt & ".xls"
        t = Len(Dir(gg))
        If t = 0 Then
            GoTo keepgoing1
        Else
            t = MsgBox("File already exists, Delete file and continue ?.", vbYesNo, "")
            If t = vbYes Then
                Kill gg
            Else
                Exit Sub
            End If
        End If
    keepgoing1:
        On Error Resume Next
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Employee Time Report Output with lunch for manual sheet", gg, True
        On Error GoTo 0
        Set Excel_Workbook = GetObject(gg)
        Set Excel_Application = Excel_Workbook.Parent
        Excel_Application.WindowState = xlMinimized
        Excel_Application.Visible = True
        Excel_Workbook.Windows(1).Visible = True
        Excel_Workbook.Worksheets(1).Name = "Employee Time Report"
        Excel_Workbook.Worksheets.Add                ''After:=Sheets(Sheets.Count)
        Set Current_Worksheet = Excel_Workbook.Worksheets("sheet1")
        Current_Worksheet.Range("A1").Value = "Yes"
        Current_Worksheet.Range("A2").Value = "No"
        Current_Worksheet.Range("A4").Value = "1"
        Current_Worksheet.Range("A5").Value = "2"
        Current_Worksheet.Range("A6").Value = "3"
        Current_Worksheet.Range("A7").Value = "4"
        Current_Worksheet.Range("A8").Value = "5"
        Current_Worksheet.Range("A9").Value = "6"
        Current_Worksheet.Range("A10").Value = "7"
        Current_Worksheet.Range("A11").Value = "8"
        Current_Worksheet.Range("A12").Value = "9"
        Current_Worksheet.Range("A13").Value = "10"
        Current_Worksheet.Range("A14").Value = "11"
        Current_Worksheet.Range("A15").Value = "12"
        Current_Worksheet.Range("A4:A15").NumberFormat = "0"
        Current_Worksheet.Range("B1").Value = "I Agree"
        Current_Worksheet.Range("B2").Value = "I Don't Agree"
        Current_Worksheet.Range("D1").Value = "Mon"
        Current_Worksheet.Range("D2").Value = "Tue"
        Current_Worksheet.Range("D3").Value = "Wed"
        Current_Worksheet.Range("D4").Value = "Thu"
        Current_Worksheet.Range("D5").Value = "Fri"
        Current_Worksheet.Range("D6").Value = "Sat"
        Current_Worksheet.Range("D7").Value = "Sun"
     
     
        Excel_Workbook.Worksheets(1).Visible = False
        Excel_Workbook.Worksheets("Employee Time Report").Tab.ColorIndex = 37
        Set Current_Worksheet = Excel_Workbook.Worksheets("Employee Time Report")
        Excel_Workbook.Worksheets("Employee Time Report").Select
        Current_Worksheet.Cells.Select
        With Selection
            Current_Worksheet.Cells.HorizontalAlignment = xlRight
            Current_Worksheet.Cells.Font.Name = "Times New Roman"
        End With
        Current_Worksheet.PageSetup.Orientation = xlLandscape
        Current_Worksheet.Range("A1:P1").HorizontalAlignment = xlCenter
        Current_Worksheet.Range("A1:P1").VerticalAlignment = xlCenter
        Current_Worksheet.Range("A1:P1").Font.Bold = True
        iddqdcNumberFormat = "d/mm/yy;@"
        Current_Worksheet.Range("D:E").NumberFormat = "h:mm"
        Current_Worksheet.Cells.SpecialCells(xlCellTypeLastCell).Select
        last_cell = Current_Worksheet.Cells.SpecialCells(xlCellTypeLastCell).Address
        rng1 = "A$1:P$" & Mid(last_cell, 4, 3)                ' Mid(Current_Worksheet.Cells.SpecialCells(xlCellTypeLastCell).Address, 4, 3) - 1"
        Current_Worksheet.Range(rng1).Select
        With Selection
            Current_Worksheet.ListObjects.Add(xlSrcRange, , xlYes, xlYes).Name = "List1"
        End With
        Current_Worksheet.Range("A$2:P" & Mid(last_cell, 4, 3)).Font.Size = 14
        '   set totals row
        Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 2).Formula = "=Sum($M2:$M" & Mid(last_cell, 4, 3)
        Current_Worksheet.Range("N" & Mid(last_cell, 4, 3) + 2).Formula = "=Sum($N2:$N" & Mid(last_cell, 4, 3)
        Current_Worksheet.Range("O" & Mid(last_cell, 4, 3) + 2).Formula = "=Sum($O2:$O" & Mid(last_cell, 4, 3)
        Current_Worksheet.Range("P" & Mid(last_cell, 4, 3) + 2).Formula = "=Sum($P2:$P" & Mid(last_cell, 4, 3)
        Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 2 & ":P" & Mid(last_cell, 4, 3) + 2).NumberFormat = "[h]:mm"
        Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 2).Value = "Totals"
        Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 2 & ":P" & Mid(last_cell, 4, 3) + 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 2 & ":P" & Mid(last_cell, 4, 3) + 2).Font.Bold = True
        Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 2 & ":L" & Mid(last_cell, 4, 3) + 2).Merge
        Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 2 & ":L" & Mid(last_cell, 4, 3) + 2).HorizontalAlignment = xlCenter
        Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 2).Font.Size = 16
    
        ' 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
        Current_Worksheet.Range("A:A").ColumnWidth = 8
        Current_Worksheet.Range("B:B").ColumnWidth = 4
        Current_Worksheet.Range("C:C").ColumnWidth = 8
        Current_Worksheet.Range("D:D").ColumnWidth = 8
        Current_Worksheet.Range("E:E").ColumnWidth = 8
        Current_Worksheet.Range("F:F").ColumnWidth = 8
        Current_Worksheet.Range("G:G").ColumnWidth = 2
        Current_Worksheet.Range("H:H").ColumnWidth = 6.5
        Current_Worksheet.Range("I:I").ColumnWidth = 7
        Current_Worksheet.Range("J:J").ColumnWidth = 7.5
        Current_Worksheet.Range("K:K").ColumnWidth = 10
        Current_Worksheet.Range("L:L").ColumnWidth = 2
        Current_Worksheet.Range("M:M").ColumnWidth = 10
        Current_Worksheet.Range("N:N").ColumnWidth = 10
        Current_Worksheet.Range("O:O").ColumnWidth = 10
        Current_Worksheet.Range("P:P").ColumnWidth = 10
        Current_Worksheet.Range("A2").Select
        Current_Worksheet.Rows("1:1").Insert Shift:=xlDown
        Current_Worksheet.Rows("1:1").Insert Shift:=xlDown
        Current_Worksheet.Rows("1:1").Insert Shift:=xlDown
        Current_Worksheet.Rows("1:1").Insert Shift:=xlDown
        Current_Worksheet.Range("A1").FormulaR1C1 = "Employee Time Tracking - "
        Current_Worksheet.Range("A1").Cells.HorizontalAlignment = xlLeft
        Current_Worksheet.Range("A1:P1").MergeCells = True
        Current_Worksheet.Range("A1:P1").Font.Bold = True
        Current_Worksheet.Range("A1:P1").Font.Size = 20
        Current_Worksheet.Range("A1:P1").Font.Name = "Times New Roman"
        Current_Worksheet.Range("A1:P1").Interior.ColorIndex = 35
        Current_Worksheet.Range("A1:P1").Borders(xlEdgeTop).LineStyle = xlContinuous
        Current_Worksheet.Range("A1:P1").Borders(xlEdgeBottom).LineStyle = xlContinuous
        Current_Worksheet.Range("A1:P1").Borders(xlEdgeLeft).LineStyle = xlContinuous
        Current_Worksheet.Range("A1:P1").Borders(xlEdgeRight).LineStyle = xlContinuous
        last_cell = Current_Worksheet.Cells.SpecialCells(xlCellTypeLastCell).Address
        Current_Worksheet.Range("A5:P5").WrapText = True
        Current_Worksheet.Range("5:5").RowHeight = 31.5
        Current_Worksheet.Range("5:5").VerticalAlignment = xlBottom
        ''Current_Worksheet.Columns("J:K").Delete
     
        Current_Worksheet.Range("A$5:F" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeRight).LineStyle = xlContinuous
        Current_Worksheet.Range("A$5:F" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeTop).LineStyle = xlContinuous
        Current_Worksheet.Range("A$5:F" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Current_Worksheet.Range("A$5:F" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeLeft).LineStyle = xlContinuous
        Current_Worksheet.Range("A$6:F" & Mid(last_cell, 4, 3) - 2).Borders(xlInsideVertical).Weight = xlHairline
        Current_Worksheet.Range("A$6:F" & Mid(last_cell, 4, 3) - 2).Borders(xlInsideHorizontal).Weight = xlHairline
        Current_Worksheet.Range("H$5:K" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeRight).LineStyle = xlContinuous
        Current_Worksheet.Range("H$5:K" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeTop).LineStyle = xlContinuous
        Current_Worksheet.Range("H$5:K" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Current_Worksheet.Range("H$5:K" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeLeft).LineStyle = xlContinuous
        Current_Worksheet.Range("H$6:K" & Mid(last_cell, 4, 3) - 2).Borders(xlInsideVertical).Weight = xlHairline
        Current_Worksheet.Range("H$6:K" & Mid(last_cell, 4, 3) - 2).Borders(xlInsideHorizontal).Weight = xlHairline
        Current_Worksheet.Range("M$5:P" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeRight).LineStyle = xlContinuous
        Current_Worksheet.Range("M$5:P" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeTop).LineStyle = xlContinuous
        Current_Worksheet.Range("M$5:P" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Current_Worksheet.Range("M$5:P" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeLeft).LineStyle = xlContinuous
        Current_Worksheet.Range("M$6:P" & Mid(last_cell, 4, 3) - 2).Borders(xlInsideVertical).Weight = xlHairline
        Current_Worksheet.Range("M$6:P" & Mid(last_cell, 4, 3) - 2).Borders(xlInsideHorizontal).Weight = xlHairline
        Current_Worksheet.Range("G$5:G" & Mid(last_cell, 4, 3) - 2).Interior.Color = 16777215
        Current_Worksheet.Range("L$5:L" & Mid(last_cell, 4, 3) - 2).Interior.Color = 16777215
        Current_Worksheet.Range("G$5:G" & Mid(last_cell, 4, 3) - 2).Font.Color = 16777215
        Current_Worksheet.Range("L$5:L" & Mid(last_cell, 4, 3) - 2).Font.Color = 16777215
        Current_Worksheet.Range("L$5:L" & Mid(last_cell, 4, 3) - 2).Font.Size = 1
        Current_Worksheet.Range("A$6:A" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeRight).Weight = xlMedium
        Current_Worksheet.Range("A$6:A" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeTop).Weight = xlMedium
        Current_Worksheet.Range("A$6:A" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeBottom).Weight = xlMedium
        Current_Worksheet.Range("A$6:A" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeLeft).Weight = xlMedium
        Current_Worksheet.Range("C$6:F" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeRight).Weight = xlMedium
        Current_Worksheet.Range("C$6:F" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeTop).Weight = xlMedium
        Current_Worksheet.Range("C$6:F" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeBottom).Weight = xlMedium
        Current_Worksheet.Range("C$6:F" & Mid(last_cell, 4, 3) - 2).Borders(xlEdgeLeft).Weight = xlMedium
        Current_Worksheet.Rows("4:4").Insert Shift:=xlDown
        Current_Worksheet.Rows("4:4").Insert Shift:=xlDown
        Current_Worksheet.Range("A8:P" & Mid(last_cell, 4, 3) + 2).Font.Size = 16
        Current_Worksheet.Range("A8:L" & Mid(last_cell, 4, 3) + 2).Font.Size = 10
        Current_Worksheet.Range("A6:P6").Font.Size = 14
        ' set spaces between list columns
        With Current_Worksheet                ' set list row titles
            .Range("B7").Value = "Day"
            .Range("C7").Value = "IN"
            .Range("D7").Value = "Lunch Start"
            .Range("E7").Value = "Lunch End"
            .Range("F7").Value = "OUT"
            .Range("H7").Value = "Time @ Lunch"
            .Range("I7").Value = "Hours Worked"
            .Range("J7").Value = "Miniutes worked"
            .Range("K7").Value = "Paid Hours Worked"
            .Range("M7").Value = "Ordinary Hours"
            .Range("N7").Value = "Time and a Half"
            .Range("O7").Value = "Double Time"
            .Range("P7").Value = "Total Hours"
        End With
        Current_Worksheet.Range("A6").Value = "TimeTracK Data"
        Current_Worksheet.Range("A6:F6").MergeCells = True
        Current_Worksheet.Range("A6:F6").HorizontalAlignment = xlCenter
        Current_Worksheet.Range("H6").Value = "Calculated Times"
        Current_Worksheet.Range("H6:K6").MergeCells = True
        Current_Worksheet.Range("H6:K6").HorizontalAlignment = xlCenter
        Current_Worksheet.Range("M6").Value = "Payroll Offce Use"
        Current_Worksheet.Range("M6:P6").MergeCells = True
        Current_Worksheet.Range("M6:P6").HorizontalAlignment = xlCenter
     
    
        '' sums go here
        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(OR(ISBLANK(A8),ISBLANK(C8),ISBLANK(D8),ISBLANK(E8),ISBLANK(F8)),1,IF(OR(ISERROR(H8),ISERROR(I8),ISERROR(O8),ISERROR(P8)),1,IF(H8<=0,1,IF(J8>0.04097,1,10))))"
    
        Current_Worksheet.Range("L8:L" & Mid(last_cell, 4, 3)).Formula = "=TEXT($B8," & Chr(34) & "Ddd" & Chr(34) & ")"
        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 = "=($F8-$C8)-($E8-$D8)"
        Current_Worksheet.Range("M8").Formula = "=IF(OR($L8 = " & Chr(34) & "Sat" & Chr(34) & ", $L8 = " & Chr(34) & "Sun" & Chr(34) & "), 0, IF($K8*24 > 8, 8/24, $K8))"
        Current_Worksheet.Range("N8").Formula = "=IF($L8=" & Chr(34) & "Sun" & Chr(34) & ",0,IF(AND($L8=" & Chr(34) & "Sat" & Chr(34) & ",$K8*24>3),3/24,IF(AND($L8=" & Chr(34) & "Sat" & Chr(34) & ",$K8*24<=3),$K8,IF(AND(NOT($L8=" & Chr(34) & "Sat" & Chr(34) & "),NOT($L8=" & Chr(34) & "Sun" & Chr(34) & ")),IF(AND($K8*24>8,  $K8*24<=11), (($K8*24)-8)/24,IF($K8*24>=11,    3/24,IF($K8*24<=8,$K8-$K8)))))))"
        Current_Worksheet.Range("O8").Formula = "=IF($L8=" & Chr(34) & "Sun" & Chr(34) & ",$K8,IF(AND($L8=" & Chr(34) & "Sat" & Chr(34) & ",($K8*24)-3<=3),($K8*24-3)/24,IF(AND($L8=" & Chr(34) & "Sat" & Chr(34) & ",($K8*24)-3>3), $K8-3/24,IF(AND(NOT($L8=" & Chr(34) & "Sat" & Chr(34) & "),NOT($L8=" & Chr(34) & "Sun" & Chr(34) & "),$K8*24>=11),(($K8*24)-11)/24,0))))"
    
        Current_Worksheet.Range("P8").Formula = "=($O8*2)+($N8*1.5)+$M8"
        Current_Worksheet.Range("I:I").NumberFormat = "[h]"
        Current_Worksheet.Range("J:J").NumberFormat = "[m]"
        Current_Worksheet.Range("M8:P" & Mid(last_cell, 4, 3)).NumberFormat = "[h]:mm"
        ''   Current_Worksheet.Range("Q8").Formula = "=($O8*2)+($N8*1.5)+$M8"
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 1 & ":F" & Mid(last_cell, 4, 3) + 1).MergeCells = True
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 1).Value = "Amend above as required prior to submision"
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 1).HorizontalAlignment = xlCenter
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 1 & ":A" & Mid(last_cell, 4, 3) + 1).Font.Size = 10
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 2 & ":F" & Mid(last_cell, 4, 3) + 2).MergeCells = True
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 2).Value = "Enter times in 24 hour format.(7:00=7am 13:00=1pm)"
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 2).HorizontalAlignment = xlCenter
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 2).VerticalAlignment = xlTop
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 2 & ":F" & Mid(last_cell, 4, 3) + 2).Font.Size = 10
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 1 & ":P" & Mid(last_cell, 4, 3) + 1).RowHeight = 13.2
        Current_Worksheet.Range("H" & Mid(last_cell, 4, 3) + 1 & ":P" & Mid(last_cell, 4, 3) + 1).MergeCells = True
        Current_Worksheet.Range("H" & Mid(last_cell, 4, 3) + 1).Value = "Calculated cells have been protected"
        Current_Worksheet.Range("H" & Mid(last_cell, 4, 3) + 1).HorizontalAlignment = xlCenter
        Current_Worksheet.Range("J" & Mid(last_cell, 4, 3) + 2).Font.Size = 16
        ' set conditional cell formats
    
        Current_Worksheet.Range("A8:F" & Mid(last_cell, 4, 3)).Select
        With Selection
            Current_Worksheet.Range("A8:F" & Mid(last_cell, 4, 3)).FormatConditions.Add Type:=xlExpression, Formula1:="=ISblank(A8:F" & Mid(last_cell, 4, 3)
            Current_Worksheet.Range("A8:F" & Mid(last_cell, 4, 3)).FormatConditions(1).Interior.Color = 255
        End With
     
        Current_Worksheet.Range("H8:K" & Mid(last_cell, 4, 3)).Select
        With Selection
            Current_Worksheet.Range("H8:K" & Mid(last_cell, 4, 3)).FormatConditions.Add Type:=xlExpression, Formula1:="=$G8<3"
            Current_Worksheet.Range("H8:K" & Mid(last_cell, 4, 3)).FormatConditions(1).Interior.Color = 16777215
            Current_Worksheet.Range("H8:K" & Mid(last_cell, 4, 3)).FormatConditions(1).Font.Color = 16777215
        End With
        Current_Worksheet.Range("M8:P" & Mid(last_cell, 4, 3)).Select
        With Selection
            Current_Worksheet.Range("M8:P" & Mid(last_cell, 4, 3)).FormatConditions.Add Type:=xlExpression, Formula1:="=$G8<3"
            Current_Worksheet.Range("M8:P" & Mid(last_cell, 4, 3)).FormatConditions(1).Interior.Color = 16777215
            Current_Worksheet.Range("M8:P" & Mid(last_cell, 4, 3)).FormatConditions(1).Font.Color = 16777215
        End With
        For i = 8 To Mid(last_cell, 4, 3)
            Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 2 & ":P" & Mid(last_cell, 4, 3) + 2).Select
            With Selection
                Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 2 & ":P" & Mid(last_cell, 4, 3) + 2).FormatConditions.Add Type:=xlExpression, Formula1:="=$G" & i & "<3"
                Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 2 & ":P" & Mid(last_cell, 4, 3) + 2).FormatConditions(i - 7).Interior.Color = 16777215
                Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 2 & ":P" & Mid(last_cell, 4, 3) + 2).FormatConditions(i - 7).Font.Color = 16777215
            End With
        Next i
        For ii = 8 To Mid(last_cell, 4, 3)
            ttt = Current_Worksheet.Range("A" & ii & ":" & "F" & ii).FormatConditions.Count
            Current_Worksheet.Range("A" & ii & ":" & "F" & ii).Select
            With Selection
                Current_Worksheet.Range("A" & ii & ":" & "F" & ii).FormatConditions.Add Type:=xlExpression, Formula1:="=$L" & ii & "=" & Chr(34) & "Sat" & Chr(34) & ""
                Current_Worksheet.Range("A" & ii & ":" & "F" & ii).FormatConditions(2).Font.Color = -16744448
            End With
        Next ii
    
        For iii = 8 To Mid(last_cell, 4, 3)
            Current_Worksheet.Range("A" & iii & ":" & "F" & iii).Select
            With Selection
                Current_Worksheet.Range("A" & iii & ":" & "F" & iii).FormatConditions.Add Type:=xlExpression, Formula1:="=$L" & iii & "=" & Chr(34) & "Sun" & Chr(34) & ""
                Current_Worksheet.Range("A" & iii & ":" & "F" & iii).FormatConditions(3).Font.Color = 255
            End With
        Next iii
        For iii = 8 To Mid(last_cell, 4, 3)
            ttt = Current_Worksheet.Range("H" & iii & ":" & "K" & iii).FormatConditions.Count
            Current_Worksheet.Range("H" & iii & ":" & "K" & iii).Select
            With Selection
                Current_Worksheet.Range("H" & iii & ":" & "K" & iii).FormatConditions.Add Type:=xlExpression, Formula1:="=$L" & iii & "=" & Chr(34) & "Sun" & Chr(34) & ""
                Current_Worksheet.Range("H" & iii & ":" & "K" & iii).FormatConditions(2).Font.Color = 255
            End With
        Next iii
        For iii = 8 To Mid(last_cell, 4, 3)
            ttt = Current_Worksheet.Range("M" & iii & ":" & "P" & iii).FormatConditions.Count
            Current_Worksheet.Range("M" & iii & ":" & "P" & iii).Select
            With Selection
                Current_Worksheet.Range("M" & iii & ":" & "P" & iii).FormatConditions.Add Type:=xlExpression, Formula1:="=$L" & iii & "=" & Chr(34) & "Sun" & Chr(34) & ""
                Current_Worksheet.Range("M" & iii & ":" & "P" & iii).FormatConditions(2).Font.Color = 255
            End With
        Next iii
        For iii = 8 To Mid(last_cell, 4, 3)
            ttt = Current_Worksheet.Range("H" & iii & ":" & "K" & iii).FormatConditions.Count
            Current_Worksheet.Range("H" & iii & ":" & "K" & iii).Select
            With Selection
                Current_Worksheet.Range("H" & iii & ":" & "K" & iii).FormatConditions.Add Type:=xlExpression, Formula1:="=$L" & iii & "=" & Chr(34) & "Sat" & Chr(34) & ""
                Current_Worksheet.Range("H" & iii & ":" & "K" & iii).FormatConditions(3).Font.Color = -16744448
            End With
        Next iii
        For iii = 8 To Mid(last_cell, 4, 3)
            ttt = Current_Worksheet.Range("M" & iii & ":" & "P" & iii).FormatConditions.Count
            Current_Worksheet.Range("M" & iii & ":" & "P" & iii).Select
            With Selection
                Current_Worksheet.Range("M" & iii & ":" & "P" & iii).FormatConditions.Add Type:=xlExpression, Formula1:="=$L" & iii & "=" & Chr(34) & "Sat" & Chr(34) & ""
                Current_Worksheet.Range("M" & iii & ":" & "P" & iii).FormatConditions(3).Font.Color = -16744448
            End With
        Next iii
        ''''''''''''''''''''''''
        Set newiconset = Current_Worksheet.Range("G8:G" & Mid(last_cell, 4, 3)).FormatConditions.AddIconSetCondition
        With Current_Worksheet.Range("G8:G" & Mid(last_cell, 4, 3)).FormatConditions(1).IconCriteria(2)
            .Type = xlConditionValueNumber
            .Value = 1
            .Operator = 7
            .Icon = xlIconRedCross
        End With
        With Current_Worksheet.Range("G8:G" & Mid(last_cell, 4, 3)).FormatConditions(1).IconCriteria(3)
            .Type = xlConditionValueNumber
            .Value = 3
            .Operator = 5
            .Icon = xlIconGreenCheck
        End With
    
        Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 8).Font.Color = 16777215
        Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 8).Value = 10
        Set newiconset2 = Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 8).FormatConditions.AddIconSetCondition
        With Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 8).FormatConditions(1).IconCriteria(2)
            .Type = xlConditionValueNumber
            .Value = 0
            .Operator = 5
            .Icon = xlIconRedCross
        End With
        With Current_Worksheet.Range("G" & Mid(last_cell, 4, 3) + 8).FormatConditions(1).IconCriteria(3)
            .Type = xlConditionValueNumber
            .Value = 1
            .Operator = 7
            .Icon = xlIconRedCross
        End With
        Current_Worksheet.Range("L" & Mid(last_cell, 4, 3) + 8).Font.Color = 16777215
        Current_Worksheet.Range("L" & Mid(last_cell, 4, 3) + 8).Value = 10
        Set newiconset3 = Current_Worksheet.Range("L" & Mid(last_cell, 4, 3) + 8).FormatConditions.AddIconSetCondition
        With Current_Worksheet.Range("L" & Mid(last_cell, 4, 3) + 8).FormatConditions(1).IconCriteria(2)
            .Type = xlConditionValueNumber
            .Value = 0
            .Operator = 5
            .Icon = xlIconGreenCheck
        End With
        With Current_Worksheet.Range("L" & Mid(last_cell, 4, 3) + 8).FormatConditions(1).IconCriteria(3)
            .Type = xlConditionValueNumber
            .Value = 1
            .Operator = 7
            .Icon = xlIconGreenCheck
        End With
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 3).Value = "Employee Verification (Select from List)"
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 3).HorizontalAlignment = xlLeft
        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) + 4).Value = "By submiting electronic copy of worksheet, I verify that I have recorded all details of these shifts accurately."
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 4).RowHeight = 20
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 4).HorizontalAlignment = xlLeft
        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 = 40
        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("B" & Mid(last_cell, 4, 3) + 8).Value = "Indicates missing times."
        Current_Worksheet.Range("H" & Mid(last_cell, 4, 3) + 8).Value = "Indicates Error In calculation."
        Current_Worksheet.Range("H" & Mid(last_cell, 4, 3) + 8).HorizontalAlignment = xlLeft
        Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 8).Value = "Indicates Correct calculation."
        Current_Worksheet.Range("M" & Mid(last_cell, 4, 3) + 8).HorizontalAlignment = xlLeft
        Current_Worksheet.Range("C" & Mid(last_cell, 4, 3) + 8).HorizontalAlignment = xlLeft
        Current_Worksheet.Range("A" & Mid(last_cell, 4, 3) + 8).Interior.Color = 255
        Current_Worksheet.Range("N" & Mid(last_cell, 4, 3) + 4).Value = "Times for Saturday shown in Green"
        Current_Worksheet.Range("N" & Mid(last_cell, 4, 3) + 4).HorizontalAlignment = xlLeft
        Current_Worksheet.Range("N" & Mid(last_cell, 4, 3) + 4).Font.Color = -16744448
        Current_Worksheet.Range("N" & Mid(last_cell, 4, 3) + 5).Value = "   Times for Sunday shown in Red"
        Current_Worksheet.Range("N" & Mid(last_cell, 4, 3) + 5).HorizontalAlignment = xlLeft
        Current_Worksheet.Range("N" & Mid(last_cell, 4, 3) + 5).VerticalAlignment = xlTop
        Current_Worksheet.Range("N" & Mid(last_cell, 4, 3) + 5).Font.Color = 255
        '' data validation
        Current_Worksheet.Range("F" & Mid(last_cell, 4, 3) + 3 & ":H" & Mid(last_cell, 4, 3) + 3).Merge
        Current_Worksheet.Range("F" & Mid(last_cell, 4, 3) + 3).Interior.Color = 15195315
        Current_Worksheet.Range("F" & Mid(last_cell, 4, 3) + 3).HorizontalAlignment = xlCenter
        '' I agree validation
        With Current_Worksheet.Range("F" & Mid(last_cell, 4, 3) + 3).Cells.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=sheet1!$B1:$B2"
            .IgnoreBlank = True
            .InCellDropdown = True
            .ShowInput = True
            .ShowError = True
        End With
        With Current_Worksheet.Range("A8:A" & Mid(last_cell, 4, 3)).Cells.Validation
            .Delete
            .Add Type:=xlValidateDate, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="1/1/2012", Formula2:="1/1/2025"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    
        Current_Worksheet.Range("B:B").HorizontalAlignment = xlLeft
        Current_Worksheet.Range("B:B").Font.Italic = True
        Current_Worksheet.Range("A:A").NumberFormat = "dd/mm/yy"
        Current_Worksheet.Range("B8" & ":B" & Mid(last_cell, 4, 3)).NumberFormat = "Ddd"
    
        Excel_Application.ActiveWindow.TabRatio = 0.192
        Current_Worksheet.PageSetup.PrintArea = ("$A$1:$P$" & Mid(last_cell, 4, 3) + 7)
    
        Current_Worksheet.Range("I3").Value = "Selected Pay Range - " & Format(Forms![main menu]![start_date], "DDD D, MMM YYYY") & " ~ to ~ " & Format(Forms![main menu]![start_date] + (Mid(last_cell, 4, 3) - 8), "DDD D, MMM YYYY")
        Current_Worksheet.Range("I3:P3").MergeCells = True
        Current_Worksheet.Range("I3:P3").HorizontalAlignment = xlCenter
        Current_Worksheet.Range("I3:P3").Font.Bold = True
        Current_Worksheet.Range("I3:P3").Font.Size = 12
        Current_Worksheet.Range("I3:P3").Font.Name = "Times New Roman"
        Current_Worksheet.Range("A7:P7").Font.Size = 10
        Current_Worksheet.Range("8:8").Select
        Excel_Application.ActiveWindow.FreezePanes = True
        Current_Worksheet.Shapes.AddTextbox(1, 5, 30, 265, 45).TextFrame.Characters.Text = "Managers need to submit an electronic copy of the payroll summary sheet and a physical copy of the Casual time sheet with required signatures (Every second Tuesday by 4.00pm)"
        Current_Worksheet.Shapes(1).Fill.ForeColor.RGB = RGB(178, 218, 236)
        Current_Worksheet.Shapes(1).TextFrame2.TextRange.Font.Size = 10
        Current_Worksheet.Shapes(1).TextFrame2.TextRange.Font.Name = "Times New Roman"
        Current_Worksheet.Shapes(1).TextFrame.VerticalAlignment = xlVAlignCenter
        Current_Worksheet.Shapes(1).TextFrame.HorizontalAlignment = xlHAlignCenter
        Current_Worksheet.Shapes.AddTextbox(1, 720, 15, 230, 120).TextFrame.Characters.Text = "This form must be completed and RETURNED TO Manager In Charge ON  A FORTNIGHTLY BASIS, Recurring calendar invitations will be sent to Anna, Tony, Kem and Ashley Fortnightly."
        Current_Worksheet.Shapes(2).Fill.ForeColor.RGB = RGB(178, 218, 236)
        Current_Worksheet.Shapes(2).TextFrame2.TextRange.Font.Size = 14
        Current_Worksheet.Shapes(2).TextFrame2.TextRange.Font.Name = "Times New Roman"
        Current_Worksheet.Shapes.AddTextbox(1, 720, 150, 230, 120).TextFrame.Characters.Text = "Additional Rows can be inserted were required or Delete rows as required." & Chr(13) & "" & Chr(13) & "To insert or remove rows you must first unprotect the worksheet."
        Current_Worksheet.Shapes(3).Fill.ForeColor.RGB = RGB(178, 218, 236)
        Current_Worksheet.Shapes(3).TextFrame2.TextRange.Font.Size = 14
        Current_Worksheet.Shapes(3).TextFrame2.TextRange.Font.Name = "Times New Roman"
        Current_Worksheet.Shapes.AddTextbox(1, 720, 280, 230, 120).TextFrame.Characters.Text = "Changes can only be made to the Date cells in column A, and the Time cells in columns C to F. When all cells have been filled with valid Times/Dates, The results will be shown."
        Current_Worksheet.Shapes(4).Fill.ForeColor.RGB = RGB(178, 218, 236)
        Current_Worksheet.Shapes(4).TextFrame2.TextRange.Font.Size = 14
        Current_Worksheet.Shapes(4).TextFrame2.TextRange.Font.Name = "Times New Roman"
        Current_Worksheet.Range("F" & Mid(last_cell, 4, 3) + 3).Select
        '   protect worksheet cells
        ''   Current_Worksheet.Cells.Locked = True
        ''  Current_Worksheet.Range("C7:F" & Mid(last_cell, 4, 3)).Locked = FLASE
        ''   Current_Worksheet.Range("A7:A" & Mid(last_cell, 4, 3)).Locked = False
        ''   Current_Worksheet.Range("F" & Mid(last_cell, 4, 3) + 3 & ":H" & Mid(last_cell, 4, 3) + 3).Locked = False
        ''   Current_Worksheet.Protect Password:=11, DrawingObjects:=True, Contents:=True, Scenarios:=True
        ''   Current_Worksheet.EnableSelection = xlUnlockedCells
        With Current_Worksheet.PageSetup
            .CenterHorizontally = True
            .Zoom = 110
            .LeftMargin = 0
            .RightMargin = 0
            .TopMargin = 0
            .BottomMargin = 0
        End With
        Excel_Workbook.Save
    End Sub

  6. #6
    trevor40's Avatar
    trevor40 is offline Advanced db Manager
    Windows 7 64bit Access 2010 64bit
    Join Date
    Feb 2014
    Location
    Australia
    Posts
    402
    Here's another bit I found, how to add VBA code for a mcro button in excel

    Code:
        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
    and

    [CODE]' 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
    /CODE]


    And the buttons...

    Code:
        Excel_Workbook.Worksheets("Summary").Buttons.Add(800, 5, 230, 40).Select
        Excel_Workbook.Worksheets("Summary").Buttons(1).Select
        Excel_Workbook.Worksheets("Summary").Buttons(1).Characters.Text = "Print Preview"
        Excel_Workbook.Worksheets("Summary").Buttons(1).OnAction = "print_preview"
        Excel_Workbook.Worksheets("Summary").Buttons(1).Font.Name = "Times New Roman"
        Excel_Workbook.Worksheets("Summary").Buttons(1).Font.Size = 34
        Excel_Workbook.Worksheets("Summary").Buttons.Add(800, 55, 230, 40).Select
        Excel_Workbook.Worksheets("Summary").Buttons(2).Select
        Excel_Workbook.Worksheets("Summary").Buttons(2).Characters.Text = "Save & Email"
        Excel_Workbook.Worksheets("Summary").Buttons(2).OnAction = "Send_Mail"
        Excel_Workbook.Worksheets("Summary").Buttons(2).Font.Name = "Times New Roman"
        Excel_Workbook.Worksheets("Summary").Buttons(2).Font.Size = 34

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

Similar Threads

  1. Export table to pre-existing worksheet in a workbook
    By coach32 in forum Import/Export Data
    Replies: 2
    Last Post: 08-12-2016, 05:15 PM
  2. Replies: 2
    Last Post: 05-16-2013, 07:43 PM
  3. export quety result to existing excel workbook
    By jsimha in forum Import/Export Data
    Replies: 1
    Last Post: 01-19-2013, 06:49 AM
  4. export query into existing workbook
    By hklein in forum Programming
    Replies: 3
    Last Post: 05-08-2012, 04:55 AM
  5. Exporting Query Results to an existing Excel Workbook
    By Dnphm in forum Import/Export Data
    Replies: 3
    Last Post: 07-13-2010, 11:40 AM

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