Private Sub cmdT2T_Click()
Dim xlApp As Object
Dim xlWB As Object
Dim wsNew As Object
Dim rsRoster As DAO.Recordset
Dim rsLeave As DAO.Recordset
Dim dbCurr As DAO.Database
Dim strRoster As String
Dim strLeave As String
Dim rng As Object
Dim filepath As String
Dim filename As String
Dim rownum As Integer
Dim i As Integer
Dim Mrng As Object
'Set variables
filepath = "\\corp\coi$\USCC\USAE\Troop 2 Task\"
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add
Set xlSh = xlWB.ActiveSheet
xlApp.Visible = True
'Set recordsets
Set dbCurr = CurrentDb()
strRoster = "SELECT Roster.[DoD ID], Roster.[Last Name], Roster.[First Name] " _
& "FROM Roster " _
& "WHERE (((Roster.[Last Name]) Not Like 'AAA*') AND ((Roster.Status) Not Like 'Archive')) " _
& "ORDER BY Roster.[Last Name];"
Set rsRoster = dbCurr.OpenRecordset(strRoster)
strLeave = "SELECT Roster.[DoD ID], Leave.[Start Date], Leave.[End Date], Roster.Status " _
& "FROM Roster INNER JOIN Leave ON Roster.[DoD ID] = Leave.[DoD ID] " _
& "WHERE (((Leave.[Start Date]) Between DateSerial(Year(Date()),1,1) And DateSerial(Year(Date()),12,31)) AND ((Roster.Status) Not Like 'Archive')) OR (((Leave.[End Date]) Between DateSerial(Year(Date()),1,1) And DateSerial(Year(Date()),12,31)));"
Set rsLeave = dbCurr.OpenRecordset(strLeave)
'Control Information
xlSh.Name = "FY " & Format(Date, "YY")
xlSh.Range("D:ND").ColumnWidth = "10"
xlSh.cells(3, 1).Value = "DoD ID"
xlSh.cells(3, 2).Value = "Last Name"
xlSh.cells(3, 3).Value = "First Name"
xlSh.Columns("A").ColumnWidth = "10"
xlSh.Columns("B").ColumnWidth = "15"
xlSh.Columns("C").ColumnWidth = "15"
xlSh.cells(2, 4).Value = "1"
xlSh.cells(2, 4).HorizontalAlignment = xlVAlignCenter
xlSh.cells(2, 5).Value = "2"
xlSh.cells(2, 5).HorizontalAlignment = xlVAlignCenter
xlSh.cells(3, 4).Value = "Friday"
xlSh.cells(3, 4).HorizontalAlignment = xlVAlignCenter
With xlSh.Range("A1", "C2")
.MergeCells = True
.Interior.ColorIndex = 16
End With
With xlSh.Range("A3", "C3")
.HorizontalAlignment = xlVAlignCenter
.Font.Bold = True
.Font.Size = 14
End With
'add in the roster
xlSh.cells(4, 1).CopyFromRecordset rsRoster
rsRoster.Close
'freeze the ID and names
xlSh.Columns("D").Select
xlApp.ActiveWindow.FreezePanes = True
'Set the week days
xlSh.Range("D3").Autofill Destination:=xlSh.Range("D3:ND3"), Type:=xlFillWeekdays