Results 1 to 7 of 7
  1. #1
    trevor40's Avatar
    trevor40 is offline Advanced db Manager
    Windows XP Access 2003
    Join Date
    Feb 2014
    Location
    Australia
    Posts
    402

    export several queries to same excel workbook but each to own sheet

    Hi, I need to export several queries to the same workbook, but send each of them to thier own worksheet.

    I have been exporting to seperate workbooks but I now need to do it to the same one.

    I am looping through a list of employees selected for export, each one gets thier own sheet in the workbook.

    I have several issues,



    At the start no excel is open, then after the first employee the excel file is open, i need some way to detect this
    i need to put each one into its own sheet and name it after the employee
    i then have to format the sheet (this part is ok and working)
    then create a new sheet for the next employee and export the data to it
    and so on for all selected employees.
    i have been looking at various way to do this but i'm stuck.

    the code below has been cut from my form vba, i have removed a lot of the formatting as all of that works fine, when this is done into seperate workbooks. who can i modify it for 1 workbook with multiple sheets?

    Also am i right in thinking that the line Dim Excel_Application As Object is used to set early or late binding and i only have to comment out this line to switch between the two?

    Private Sub Command94_Click()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim gg As String
    sdt = Format(start_date, "dd-mm-yy")
    edt = Format(End_date, "dd-mm-yy")
    ' GO
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("create excel time sheets for selected employees on main menu")
    With rs
    .MoveFirst
    Do While Not .EOF
    fn = rs.Fields("First Name")
    Ln = rs.Fields("Last Name")
    ns = rs.Fields("Normal Start Time")
    ne = rs.Fields("Normal End Time")
    bc = rs.Fields("Barcode")
    gg = "C:\aaa\timesheets\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
    Me.barcode = bc

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "print time sheets for selected employees", gg, True
    On Error GoTo 0

    Dim Excel_Application As Object

    Set Excel_Application = CreateObject("Excel.Application")
    Set Excel_Workbook = GetObject(gg)

    Excel_Application.WindowState = xlMaximized
    Excel_Application.Visible = True
    Excel_Workbook.Windows(1).Visible = True
    Excel_Workbook.Worksheets(1).Name = fn & " " & Ln
    Set Current_Worksheet = Excel_Workbook.Worksheets(fn & " " & Ln)

    Excel_Workbook.Worksheets("Employee Time Report").Select
    Excel_Workbook.Worksheets("Employee Time Report").Tab.ColorIndex = 37

    Excel_Application.FormulaBarHeight = 1
    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").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"
    Current_Worksheet.Cells.SpecialCells(xlCellTypeLas tCell).Select
    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
    Current_Worksheet.Rows("2:2").Insert Shift:=xlDown
    Current_Worksheet.Range("A3:J3").Copy
    Current_Worksheet.Range("A2:J2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Current_Worksheet.Range("A$1:P" & Mid(last_cell, 4, 3) + 1).Select
    With Selection
    Current_Worksheet.ListObjects.Add(xlSrcRange, , xlYes, xlYes).Name = "List1"
    End With

    '' 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(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) & ")"
    Current_Worksheet.Range("I:I").NumberFormat = "[h]"
    Current_Worksheet.Range("J:J").NumberFormat = "[m]"
    Current_Worksheet.Range("K:K").NumberFormat = "[h]:mm"
    Current_Worksheet.Range("M8:P" & Mid(last_cell, 4, 3)).NumberFormat = "0.00"
    Current_Worksheet.Range("H8:P" & Mid(last_cell, 4, 3)).HorizontalAlignment = xlRight
    With Current_Worksheet.PageSetup
    .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
    End With
    DoEvents
    .MoveNext
    Loop
    End With
    Excel_Workbook.SaveAs "C:\aaa\timesheets\Employee Time Report for - " & sdt & " to " & edt & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Excel_Application.Quit
    Kill "C:\aaa\timesheets\Employee Time Report for - " & sdt & " to " & edt & ".xls"
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    t = MsgBox("All requested Excel Time Sheets have been created" & vbCrLf & " And saved in the following directory" & vbCrLf & vbCrLf & " C:\aaa\timesheets", vbOKOnly, "Automated Time Sheet Generation")
    End Sub

  2. #2
    June7's Avatar
    June7 is offline VIP
    Windows 7 64bit Access 2010 32bit
    Join Date
    May 2011
    Location
    The Great Land
    Posts
    52,815
    Did you test just commenting it?

    Early binding:

    Dim Excel_Application As Excel.Application

    Late binding:

    Dim Excel_Application As Object

    If you don't have Option Explicit at the top of module, maybe can get away with no Dim statement but early binding allows intellisense popup tips to be invoked.

    See if this helps http://www.accessmvp.com/KDSnell/EXC...ExportSameFile
    How to attach file: http://www.accessforums.net/showthread.php?t=70301 To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.

  3. #3
    trevor40's Avatar
    trevor40 is offline Advanced db Manager
    Windows XP Access 2003
    Join Date
    Feb 2014
    Location
    Australia
    Posts
    402
    Early binding:

    Dim Excel_Application As Excel.Application

    Late binding:

    Dim Excel_Application As Object

    If you don't have Option Explicit at the top of module, maybe can get away with no Dim statement but early binding allows intellisense popup tips to be invoked.

    See if this helps http://www.accessmvp.com/KDSnell/EXC...ExportSameFile[/QUOTE]


    thanks for that, this is what i have so far, i went back to basics just to get it going, so far it will create a wbook with 2 sheets named as expected but it can't open the excel file for editing the second time (only 2 employees selected). so im just playing around with the file types.

    Private Sub Command94_Click()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim gg As String
    sdt = Format(start_date, "dd-mm-yy")
    edt = Format(End_date, "dd-mm-yy")
    ' main file name
    gg = "C:\aaa\timesheets\Employee Time Report master.xls"

    Set db = CurrentDb()
    Set rs = db.OpenRecordset("create excel time sheets for selected employees on main menu")
    With rs
    .MoveFirst
    Do While Not .EOF
    fn = rs.Fields("First Name")
    Ln = rs.Fields("Last Name")
    bc = rs.Fields("Barcode")
    ' set employee for query
    Me.barcode = bc
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, _
    "print time sheets for selected employees", gg, True, fn & " " & Ln
    ' Dim Excel_Application As Object
    Set Excel_Application = CreateObject("Excel.Application")
    Set Excel_Workbook = GetObject(gg)
    Excel_Application.WindowState = xlMaximized
    Excel_Application.Visible = True
    Excel_Workbook.Windows(1).Visible = True
    Set Current_Worksheet = Excel_Workbook.Worksheets(fn & "_" & Ln)
    ' set each sheet's name to employee name
    Excel_Workbook.Worksheets(fn & "_" & Ln).Select
    DoEvents
    .MoveNext
    Excel_Workbook.Save 'As "C:\aaa\timesheets\Employee Time Report master.xls"
    Excel_Application.Quit
    Set Excel_Application = Nothing
    Set Excel_Workbook = Nothing
    Loop
    End With
    ' Excel_Workbook.Save
    '
    ' Kill "C:\aaa\timesheets\Employee Time Report for - " & sdt & " to " & edt & ".xls"
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    t = MsgBox("All requested Excel Time Sheets have been created" & vbCrLf & " And saved in the following directory" & vbCrLf & vbCrLf & " C:\aaa\timesheets", vbOKOnly, "Automated Time Sheet Generation")
    End Sub '************************************************* ************************************************** ********************************************

  4. #4
    June7's Avatar
    June7 is offline VIP
    Windows 7 64bit Access 2010 32bit
    Join Date
    May 2011
    Location
    The Great Land
    Posts
    52,815
    What do you mean by 'for editing the second time' - to add more worksheets?

    You are attempting something I've never done. The Ken Snell source is the best I can offer.
    How to attach file: http://www.accessforums.net/showthread.php?t=70301 To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.

  5. #5
    trevor40's Avatar
    trevor40 is offline Advanced db Manager
    Windows XP Access 2003
    Join Date
    Feb 2014
    Location
    Australia
    Posts
    402
    never mind, i have progressed beyond that. i have all my seperate sheets, one for each selected employee in the same workbook. now i'm working on opening that workbook and formatting all the sheets then saving the workbook.

  6. #6
    trevor40's Avatar
    trevor40 is offline Advanced db Manager
    Windows XP Access 2003
    Join Date
    Feb 2014
    Location
    Australia
    Posts
    402
    Hi again, so i'm up to this now, create workbook ok, copy employee sheets to seperate tabs ok, format each sheet - only the first sheet is being formatted, when it comes to do the next one it fails. i am changing to the next worksheet, i can see that happening, it then formats all cells for the first sheet, but fails on this line (only the second time) Current_Worksheet.Range("A1:P100").Select

    error is run-time error '-2147221080 (800401a8) method 'range' of object '_worksheet' failed i get the same error if i try Current_Worksheet.cells.select



    Sub format_sheets_now()
    Dim ws As excel.Worksheet
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim qdf As DAO.QueryDef
    Dim strPath As String
    Dim stDocName As String
    'Early binding
    'Dim Excel_Application As excel.Application
    'late binding
    Dim Excel_Application As Object
    Dim Excel_Workbook As Workbook
    Dim Current_Worksheet As Worksheet
    Dim gg As String
    gg = "C:\aaa\timesheets\Employee Time Report master.xls"
    sdt = Format(start_date, "dd-mm-yy")
    edt = Format(End_date, "dd-mm-yy")
    Set Excel_Workbook = GetObject(gg)
    Set Excel_Application = Excel_Workbook.Parent
    Set Current_Worksheet = Excel_Workbook.Worksheets(1)
    Excel_Application.WindowState = xlMaximized
    Excel_Application.Visible = True
    Excel_Workbook.Windows(1).Visible = True
    Excel_Workbook.Worksheets(1).Select
    t = Excel_Workbook.Worksheets.Count
    For sheet_count = 1 To Excel_Workbook.Worksheets.Count
    Excel_Workbook.Worksheets(sheet_count).Select
    Excel_Application.FormulaBarHeight = 1
    Current_Worksheet.PageSetup.Orientation = xlLandscape

    Current_Worksheet.Range("A1:P100").Select
    OR this
    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"
    Next sheet_count
    End Sub '************************************************* ************************************************** ********************************************
    '################################################# ################################################## ##########################################
    Private Sub Command94_Click()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim gg As String
    sdt = Format(start_date, "dd-mm-yy")
    edt = Format(End_date, "dd-mm-yy")
    gg = "C:\aaa\timesheets\Employee Time Report master.xls"
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("create excel time sheets for selected employees on main menu")
    With rs
    .MoveFirst
    Do While Not .EOF
    fn = rs.Fields("First Name")
    Ln = rs.Fields("Last Name")
    bc = rs.Fields("Barcode")
    Me.barcode = bc
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "print time sheets for selected employees", gg, True, fn & " " & Ln
    DoEvents
    .MoveNext
    Loop
    End With
    rs.Close
    Set rs = Nothing
    Set db = Nothing

    Call format_sheets_now

    t = MsgBox("All requested Excel Time Sheets have been created" & vbCrLf & " And saved in the following directory" & vbCrLf & vbCrLf & " C:\aaa\timesheets", vbOKOnly, "Automated Time Sheet Generation")
    End Sub '************************************************* ************************************************** ********************************************

  7. #7
    trevor40's Avatar
    trevor40 is offline Advanced db Manager
    Windows XP Access 2003
    Join Date
    Feb 2014
    Location
    Australia
    Posts
    402
    never mind, again i have got it going, now just the final debugging after putting it all together.

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

Similar Threads

  1. Replies: 1
    Last Post: 08-12-2013, 09:27 AM
  2. Replies: 1
    Last Post: 08-08-2013, 03:54 PM
  3. Replies: 2
    Last Post: 08-14-2012, 04:24 AM
  4. Replies: 1
    Last Post: 03-12-2012, 02:21 PM
  5. Export 2 Queries to Same Workbook in Access 2010
    By Mikey in forum Import/Export Data
    Replies: 2
    Last Post: 08-23-2010, 05:16 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