Private Sub cmdStaff_Click()
'This code was originally written by Dev Ashish. It is not to be altered or distributed, except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged
'Code Courtesy of
'Dev Ashish
'
'Copy records to a named range
'on an existing worksheet on a
'workbook
'Microsoft Excel 14.0 Object Library must be set
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Dim db As Database
Set db = CurrentDb
Dim rs As Recordset
Dim rs1 As Recordset
Dim excelRange As String
Const conMAX_ROWS = 1000
Const conSHT_NAME = "PI"
Const conWKB_NAME = "F:\Schedules\modSTAFF.xlsx"

Set rs1 = db.OpenRecordset("SELECT * FROM tblExcelRanges ORDER BY [ID];")
Set objXL = New Excel.Application
                    
    With rs1
        If Not (rs1.BOF And rs1.EOF) Then 'Ensure that there are actually records to work with
             rs1.MoveFirst
      
            Do While Not rs1.EOF
                                
                Set rs = db.OpenRecordset("SELECT tblStep1.EID FROM tblStep1 " & _
                        "WHERE (((tblStep1." & rs1![Wday] & ")='" & rs1![SName] & "'));", dbOpenSnapshot)
                        
                excelRange = rs1![WRange]
                With objXL
                    .Visible = True
                    Set objWkb = .Workbooks.Open(conWKB_NAME)
                    On Error Resume Next
                    Set objSht = objWkb.Worksheets(conSHT_NAME)
                    
                    If Not Err.Number = 0 Then
                        Set objSht = objWkb.Worksheets.Add
                        objSht.Name = conSHT_NAME
                    End If
                    
                    Err.Clear
                    On Error GoTo 0
                    objSht.Range(excelRange).CopyFromRecordset rs
                End With
                    objWkb.Save
                    objXL.Quit

                    Set rs = Nothing
                    rs1.MoveNext
            Loop
         End If
      End With
  
  'objWkb.Save
  'objXL.Quit
  Set objSht = Nothing
  Set objWkb = Nothing
  Set objXL = Nothing
  Set rs = Nothing
  Set rs1 = Nothing
  Set db = Nothing

End Sub

Option Compare Database
Option Explicit
'
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd&) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat&) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat&, ByVal hMem&) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
'
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes&) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem&) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem&) As Long
'
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
'
Private Declare Function FindWindowByClass Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As Long) As Long
'

Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String)
Declare Function PostMessageByNum& Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long)
Private Const WM_CLOSE = &H10
Private Const CF_TEXT = 1
'
Function clipGetText() As String
' Retrieve text from the clipboard
' If clipboard is empty, or contents
' are not textual, returns ""

    Dim hMem As Long
    Dim lpMem As Long
    Dim strResult As String
    Const BUF_SIZE = 4096
    '
    If OpenClipboard(0&) = 0 Then Exit Function
    '
    hMem = GetClipboardData(CF_TEXT)
    If hMem = 0 Then GoTo clipGetText_Exit
    '
    lpMem = GlobalLock(hMem)
    If lpMem Then
        strResult = Space$(BUF_SIZE)
        lstrcpy strResult, lpMem
        GlobalUnlock hMem
        strResult = left$(strResult, InStr(1, strResult, vbNullChar, 0) - 1)
    End If

clipGetText_Exit:
    CloseClipboard
    clipGetText = strResult

End Function

Sub clipPutText(theText As String)
' Stores text on the clipboard

    Dim hMem As Long
    Const GHND = &H42
    '
    hMem = GlobalAlloc(GHND, Len(theText) + 1)
    lstrcpy GlobalLock(hMem), theText
    If GlobalUnlock(hMem) <> 0 Then Exit Sub
    If OpenClipboard(0&) = 0 Then Exit Sub
    EmptyClipboard
    SetClipboardData CF_TEXT, hMem
    CloseClipboard

End Sub

Function IsRunning(ByVal strName As String) As Boolean
'Determine whether the named application is running.
Dim lFound As Long
Dim strClass As String
    On Error GoTo Err_IsRunning

    Select Case strName
        Case "Access":
            strClass = "OMain"
        Case "Excel":
            strClass = "XLMAIN"
        Case "Word":
            strClass = "OpusApp"
        Case "Powerpoint":
            strClass = "PP97FrameClass"
        Case "Outlook":
            strClass = "rctrl_renwnd32"
        Case Else:
            strClass = ""
    End Select
    If strClass = "" Then
        IsRunning = False
    Else
        lFound = FindWindowByClass(strClass, 0&)
        If lFound > 0 Then
            IsRunning = True
        Else
            IsRunning = False
        End If
    End If
    
Exit_IsRunning:
    Exit Function
Err_IsRunning:
    MsgBox "IsRunning: " & err.Description, vbCritical
    Resume Exit_IsRunning
End Function

Function CloseRunning(strName As String) As Boolean
Dim hTarget As Long
Dim strClass As String
    On Error GoTo Err_CloseRunning

    Select Case strName
        Case "Access":
            strClass = "OMain"
        Case "Excel":
            strClass = "XLMAIN"
        Case "Word":
            strClass = "OpusApp"
        Case "Powerpoint":
            strClass = "PP97FrameClass"
        Case "Outlook":
            strClass = "rctrl_renwnd32"
        Case Else:
            strClass = ""
    End Select
    If strClass = "" Then
        CloseRunning = False
    Else
        hTarget = FindWindowByClass(strClass, 0&)
        If hTarget > 0 Then
            CloseRunning = True
        Else
            CloseRunning = False
        End If
    End If
    ' The following line will close the app.
    ' You could instead set up a subclasser here.
    If hTarget Then Call PostMessageByNum(hTarget, WM_CLOSE, 0, 0)
        
Exit_CloseRunning:
    Exit Function
Err_CloseRunning:
    MsgBox "CloseRunning: " & err.Description, vbCritical
    Resume Exit_CloseRunning
End Function

'---------------------------------------------------------------------------------------
' Procedure : funFileExists
' Author    : Neville Turbit
' Date      : 09/06/09
' Purpose   : Check if an external file exists
'---------------------------------------------------------------------------------------
'
Public Function funFileExists(strPath As Variant, Optional lngType As Long) As Boolean
    Dim intTest As Integer
    
    On Error Resume Next                                            'Ignore errors to allow for error evaluation

    intTest = GetAttr(strPath)
  
    'Check if error exists and set response appropriately
    Select Case Err.Number
        Case Is = 0
            funFileExists = True
        Case Else
            funFileExists = False
    End Select

Exit_funFileExists:
    On Error GoTo 0
    Exit Function

End Function

Private Sub cmdStaff_Click()
On Error GoTo Err_Handler

'Copy records to a named range
'on an existing worksheet on a
'workbook
'Microsoft Excel 14.0 Object Library must be set
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Dim db As Database
Set db = CurrentDb
Dim rs As Recordset
Dim rs1 As Recordset
Dim excelRange As String
Const conMAX_ROWS = 1000
Const conSHT_NAME = "PI"
Const conWKB_NAME = "C:\Temp\modSTAFF.xlsx"

Set rs1 = db.OpenRecordset("SELECT * FROM tblExcelRanges ORDER BY [ID];")
Set objXL = New Excel.Application
                    
    With rs1
        If Not (rs1.BOF And rs1.EOF) Then 'Ensure that there are actually records to work with
            rs1.MoveLast
            rs1.MoveFirst 'not necessary but starting from the first record to troubleshoot problems
      
                With objXL
                    .Visible = True
                    Set objWkb = .Workbooks.Open(conWKB_NAME)
                    On Error Resume Next
                    Set objSht = objWkb.Worksheets(conSHT_NAME)
                    
                    If Not Err.Number = 0 Then
                        Set objSht = objWkb.Worksheets.Add
                        objSht.Name = conSHT_NAME
                    End If
                    
                    Err.Clear
                    On Error GoTo 0
                End With            
            Do While Not rs1.EOF
                                
                Set rs = db.OpenRecordset("SELECT tblStep1.EID FROM tblStep1 " & _
                        "WHERE (((tblStep1." & rs1![Wday] & ")='" & rs1![SName] & "'));", dbOpenSnapshot)
                        
                excelRange = rs1![WRange]
                    
                objSht.Range(excelRange).CopyFromRecordset rs
                Set rs = Nothing
                rs1.MoveNext
            Loop
         End If
      End With
  
  
  objWkb.Save
  'objXL.Quit
  
Exit_Handler:
    Set objSht = Nothing
    Set objWkb = Nothing
    Set objXL = Nothing
    Set rs = Nothing
    Set rs1 = Nothing
    Set db = Nothing
    Exit Sub
    
Err_Handler:
    MsgBox Err.Description
    Resume Exit_Handler

End Sub