Is there a better way?

V

Valentine

Member
Local time
Today, 14:53
Joined
Oct 1, 2021
Messages
261
I have a button that creates an Excel document. I want it make it flow better and to adjust for leap year. It has to flow October through September and have the FY as the name of the tab your on.
My current code is just 1 sheet and very long, there has to be a way to make it more streamline.

Code: 
Private Sub cmdT2T_Click()

    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSh 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
    
    'Set variables
    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Add
    Set xlSh = xlWB.ActiveSheet
    xlApp.Visible = True
    
    'Control Information
    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
    'Set the week days
    xlSh.Range("D3").Autofill Destination:=xlSh.Range("D3:ND3"), Type:=xlFillWeekdays
    'Set months title
    With xlSh.Range("D1", "AH1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 37
        .Value = "October"
    End With
    'Set day numbers for each month
    xlSh.Range("D2:E2").Autofill Destination:=xlSh.Range("D2:AH2"), Type:=xlFillSeries
    With xlSh.Range("AI1", "BL1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 33
        .Value = "November"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("AI2:AK2")
    xlSh.Range("AI2:AK2").Autofill Destination:=xlSh.Range("AI2:BL2"), Type:=xlFillDefault
    With xlSh.Range("BM1", "CQ1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 37
        .Value = "December"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("BM2:BO2")
    xlSh.Range("BM2:BO2").Autofill Destination:=xlSh.Range("BM2:CQ2"), Type:=xlFillDefault
    With xlSh.Range("CR1", "DV1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 33
        .Value = "January"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("CR2:CT2")
    xlSh.Range("CR2:CT2").Autofill Destination:=xlSh.Range("CR2:DV2"), Type:=xlFillDefault
    With xlSh.Range("DW1", "EX1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 37
        .Value = "February"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("DW2:DY2")
    xlSh.Range("DW2:DY2").Autofill Destination:=xlSh.Range("DW2:EX2"), Type:=xlFillDefault
    With xlSh.Range("EY1", "GC1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 33
        .Value = "March"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("EY2:FA2")
    xlSh.Range("EY2:FA2").Autofill Destination:=xlSh.Range("EY2:GC2"), Type:=xlFillDefault
    With xlSh.Range("GD1", "HG1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 37
        .Value = "April"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("GD2:GF2")
    xlSh.Range("GD2:GF2").Autofill Destination:=xlSh.Range("GD2:HG2"), Type:=xlFillDefault
    With xlSh.Range("HH1", "IL1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 33
        .Value = "May"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("HH2:HJ2")
    xlSh.Range("HH2:HJ2").Autofill Destination:=xlSh.Range("HH2:IL2"), Type:=xlFillDefault
    With xlSh.Range("IM1", "JP1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 37
        .Value = "June"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("IM2:IO2")
    xlSh.Range("IM2:IO2").Autofill Destination:=xlSh.Range("IM2:JP2"), Type:=xlFillDefault
    With xlSh.Range("JQ1", "KU1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 33
        .Value = "July"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("JQ2:JS2")
    xlSh.Range("JQ2:JS2").Autofill Destination:=xlSh.Range("JQ2:KU2"), Type:=xlFillDefault
    With xlSh.Range("KV1", "LZ1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 37
        .Value = "August"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("KV2:KX2")
    xlSh.Range("KV2:KX2").Autofill Destination:=xlSh.Range("KV2:LZ2"), Type:=xlFillDefault
    With xlSh.Range("MA1", "ND1")
        .Font.Bold = True
        .Font.Size = 12
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlVAlignCenter
        .MergeCells = True
        .Interior.ColorIndex = 33
        .Value = "September"
    End With
    xlSh.Range("D2:F2").Copy Destination:=xlSh.Range("MA2:MC2")
    xlSh.Range("MA2:MC2").Autofill Destination:=xlSh.Range("MA2:ND2"), Type:=xlFillDefault
    'Shade in weekends
    For Each rng In xlSh.Range("D3:ND3")
        With rng
            If rng.Value = "Saturday" Then
                xlSh.Columns(.Column).Interior.ColorIndex = 16
            ElseIf rng.Value = "Sunday" Then
                xlSh.Columns(.Column).Interior.ColorIndex = 16
            End If
        End With
    Next
    'Put the list of soldiers
    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)
    xlSh.Cells(4, 1).CopyFromRecordset rsRoster
    rsRoster.Close
    Set rsRoster = Nothing
    'Freeze the names
    xlSh.Columns("D").Select
    xlApp.ActiveWindow.FreezePanes = True
 
it is better to have 2 Template workbooks (one for Leap year and the other normal year)
that has the formatted days across the sheet.
then you only need to open whichever is appropriate and SaveAs to different name.
 
ok I can do that. Is the way I have the months and days the best way or is there a loop i can do to make the code smaller?
 
I want to change this from being 1 fiscal year a sheet to just having an excel document per fiscal year with each month a different sheet. How do i go about creating the 12 sheets with VBA?
 
Unless you need to automate Excel for some reason, you can export one month at a time. If you use different query Names and export to the same file name, they'll end up as different sheets.
 
oh ok yeah I can make the button just create an excel document for the current month, awesome. I could just make each of those lines into functions and just call the current month in the code. That would also make leap years easier as i can add that into the february function. ok so thinking out loud sorry, but how do i get the months to start on the right day? Like monday, tuesday and so on so I can code that in?
 
I've lost track of what you're doing overall, which is probably fine as most questions need targeted narrow questions to get targeted accurate answers - so I'll just say you can test the month name of day 1 of a certain month.

?weekday(dateserial(year(now()),month(now())+1,1))

returns 6, because the 1st of next month is the 6th day of the week.

etc. etc.
 
yeah my question has morphed a few times since it started. Mind changing and trying to get all the info needed.

Currently I have a table that includes every soldiers leave submission with start dates and end dates.
Currently I have an excel document that I create with the above code, it is a year long on 1 sheet starting.

After conversing with command and other people to see what exactly they want it seems they want a spreadsheet that covers the entire FY but could it have each month as a different sheet?
I have no clue how to make multiple sheets for a single excel document and fill them with the appropriate information.
appropriate info:
Month
Day of the month (Monday, Tuesday, etc.)
Day of the month (1, 2, 3, etc)
Soldiers ID down left side
Soldiers Last name and first name down left side
Freeze the first 3 columns (ID, Last name, First name)
Shade weekends (Sat, Sun shaded columns)
Leave shaded out for each soldier according to the table (Start date, end date and everything in between)
 
dim x as long, wsNew as worksheet
for x = 1 to 12
set wsNew = worksheets.add(after:=thisworkbook.worksheets(thisworkbook.worksheets.count))
wsNew.name = monthname(x)
wsNew...continue doing your thing
next x
 
I am getting an "Object Required" error on the set wsNew line

Code: 
    Dim xlApp As Object
    Dim xlWB As Object
    Dim wsNew As Object
    Dim x As Long
    
    
'    'Set variables
    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Add
    xlApp.Visible = True
    
    For x = 1 To 12
        Set wsNew = Worksheets.Add(after:=xlWB.Worksheets(xlWB.Worksheets.Count))
        wsNew.Name = MonthName(x)
        wsNew.Cells(3, 1).Value = "DoD ID"
        wsNew.Cells(3, 2).Value = "Last Name"
        wsNew.Cells(3, 3).Value = "First Name"
        wsNew.Columns("A").ColumnWidth = "10"
        wsNew.Columns("B").ColumnWidth = "15"
        wsNew.Columns("C").ColumnWidth = "15"
        wsNew.Cells(2, 4).Value = "1"
        wsNew.Cells(2, 4).HorizontalAlignment = xlVAlignCenter
        wsNew.Cells(2, 5).Value = "2"
        wsNew.Cells(2, 5).HorizontalAlignment = xlVAlignCenter
        wsNew.Cells(3, 4).Value = "Friday"
        wsNew.Cells(3, 4).HorizontalAlignment = xlVAlignCenter
        With wsNew.Range("A1", "C2")
            .MergeCells = True
            .Interior.ColorIndex = 16
        End With
        With wsNew.Range("A3", "C3")
            .HorizontalAlignment = xlVAlignCenter
            .Font.Bold = True
            .Font.Size = 14
        End With
    Next x
 
fixed that I didn't have xlWB infront of the first worksheets.add.

I am now trying to add in the days and am getting mismatch error.

Code: 
        If wsNew.Name = ("January" Or "March" Or "May" Or "July" Or "August" Or "October" Or "December") Then
            wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AH2"), Type:=xlFillSeries
        ElseIf wsNew.Name = ("April" Or "June" Or "September" Or "November") Then
            wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AG2"), Type:=xlFillSeries
        ElseIf wsNew.Name = "February" Then
            wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AE2"), Type:=xlFillSeries
        End If
 
try

Select Case wsNew.name
case "this", "that", "the other"
..do something
case "something else"
..do something else
end select
 
awesome that worked and I added a few other things but do I have to add in a seperate if statement for each month to add in the month at the top??

Code: 
        Select Case wsNew.Name
            Case "January", "March", "May", "July", "August", "October", "December"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AH2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AH1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                End With
            Case "April", "June", "September", "November"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AG2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AG1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                End With
            Case "February"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AE2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AE1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    .Value = "February"
                End With
        End Select

see how I have it with February it puts February in the merged cells at the top of the sheet. Do I have to if statement for each month?
 
If you weren't doing something different (d2:ag2 vs. d2:ae2) on the different months then i would suggest a more efficient loop at this point. but as it is, yes, a different select statement for each month.
but, you could copy and paste the same one in each block that covers all of them.

if you really wanted to up the ante you could save a reference 'table' for configuration purposes, then look up the month to that table for 1) the ranges (then use worksheetfunction.indirect to grab the range address from the configuration table), and 2) the values etc.

but it might be shorter to just hammer it out, for just these 12 mo. if that's all your'e doing
 
so far I have:

Code: 
    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 x As Long
        
'    'Set variables
    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Add
    xlApp.Visible = True
    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)

    For x = 1 To 12
        rsRoster.MoveFirst
        Set wsNew = xlWB.Worksheets.Add(after:=xlWB.Worksheets(xlWB.Worksheets.Count))
        wsNew.Name = MonthName(x)
        wsNew.Cells(3, 1).Value = "DoD ID"
        wsNew.Cells(3, 2).Value = "Last Name"
        wsNew.Cells(3, 3).Value = "First Name"
        wsNew.Columns("A").ColumnWidth = "10"
        wsNew.Columns("B").ColumnWidth = "15"
        wsNew.Columns("C").ColumnWidth = "15"
        wsNew.Cells(2, 4).Value = "1"
        wsNew.Cells(2, 4).HorizontalAlignment = xlVAlignCenter
        wsNew.Cells(2, 5).Value = "2"
        wsNew.Cells(2, 5).HorizontalAlignment = xlVAlignCenter
        With wsNew.Range("A1", "C2")
            .MergeCells = True
            .Interior.ColorIndex = 16
        End With
        With wsNew.Range("A3", "C3")
            .HorizontalAlignment = xlVAlignCenter
            .Font.Bold = True
            .Font.Size = 14
        End With
        wsNew.Cells(4, 1).CopyFromRecordset rsRoster
        wsNew.Columns("D").Select
        xlApp.ActiveWindow.FreezePanes = True
        Select Case wsNew.Name
            Case "January", "March", "May", "July", "August", "October", "December"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AH2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AH1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    If wsNew.Name = "January" Then
                        .Value = "January"
                    ElseIf wsNew.Name = "March" Then
                        .Value = "March"
                    ElseIf wsNew.Name = "May" Then
                        .Value = "May"
                    ElseIf wsNew.Name = "July" Then
                        .Value = "July"
                    ElseIf wsNew.Name = "August" Then
                        .Value = "August"
                    ElseIf wsNew.Name = "October" Then
                        .Value = "October"
                    ElseIf wsNew.Name = "December" Then
                        .Value = "December"
                    End If
                End With
            Case "April", "June", "September", "November"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AG2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AG1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    If wsNew.Name = "April" Then
                        .Value = "April"
                    ElseIf wsNew.Name = "June" Then
                        .Value = "June"
                    ElseIf wsNew.Name = "September" Then
                        .Value = "September"
                    ElseIf wsNew.Name = "November" Then
                        .Value = "November"
                    End If
                End With
            Case "February"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AE2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AE1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    .Value = "February"
                End With
        End Select
    Next x
    rsRoster.Close
    Set rsRoster = Nothing

I need this to be an up to date representation of every soldiers availability for each move with regards to their leave. This is going to be an ongoing savable spreadsheet. I cannot figure out how to make it populate the days of the week in the spreadsheet in row 3 and then the hard part of bringing in all the leave and putting it into its appropriate position in the spreadsheet.
 
Valentine said:
so far I have:

Code: 
    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 x As Long
       
'    'Set variables
    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Add
    xlApp.Visible = True
    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)

    For x = 1 To 12
        rsRoster.MoveFirst
        Set wsNew = xlWB.Worksheets.Add(after:=xlWB.Worksheets(xlWB.Worksheets.Count))
        wsNew.Name = MonthName(x)
        wsNew.Cells(3, 1).Value = "DoD ID"
        wsNew.Cells(3, 2).Value = "Last Name"
        wsNew.Cells(3, 3).Value = "First Name"
        wsNew.Columns("A").ColumnWidth = "10"
        wsNew.Columns("B").ColumnWidth = "15"
        wsNew.Columns("C").ColumnWidth = "15"
        wsNew.Cells(2, 4).Value = "1"
        wsNew.Cells(2, 4).HorizontalAlignment = xlVAlignCenter
        wsNew.Cells(2, 5).Value = "2"
        wsNew.Cells(2, 5).HorizontalAlignment = xlVAlignCenter
        With wsNew.Range("A1", "C2")
            .MergeCells = True
            .Interior.ColorIndex = 16
        End With
        With wsNew.Range("A3", "C3")
            .HorizontalAlignment = xlVAlignCenter
            .Font.Bold = True
            .Font.Size = 14
        End With
        wsNew.Cells(4, 1).CopyFromRecordset rsRoster
        wsNew.Columns("D").Select
        xlApp.ActiveWindow.FreezePanes = True
        Select Case wsNew.Name
            Case "January", "March", "May", "July", "August", "October", "December"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AH2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AH1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    If wsNew.Name = "January" Then
                        .Value = "January"
                    ElseIf wsNew.Name = "March" Then
                        .Value = "March"
                    ElseIf wsNew.Name = "May" Then
                        .Value = "May"
                    ElseIf wsNew.Name = "July" Then
                        .Value = "July"
                    ElseIf wsNew.Name = "August" Then
                        .Value = "August"
                    ElseIf wsNew.Name = "October" Then
                        .Value = "October"
                    ElseIf wsNew.Name = "December" Then
                        .Value = "December"
                    End If
                End With
            Case "April", "June", "September", "November"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AG2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AG1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    If wsNew.Name = "April" Then
                        .Value = "April"
                    ElseIf wsNew.Name = "June" Then
                        .Value = "June"
                    ElseIf wsNew.Name = "September" Then
                        .Value = "September"
                    ElseIf wsNew.Name = "November" Then
                        .Value = "November"
                    End If
                End With
            Case "February"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AE2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AE1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    .Value = "February"
                End With
        End Select
    Next x
    rsRoster.Close
    Set rsRoster = Nothing

I need this to be an up to date representation of every soldiers availability for each move with regards to their leave. This is going to be an ongoing savable spreadsheet. I cannot figure out how to make it populate the days of the week in the spreadsheet in row 3 and then the hard part of bringing in all the leave and putting it into its appropriate position in the spreadsheet.
Click to expand...
Do you and your coworkers realize this needs to be a database? The struggle is only going to get worse from here.
 
yeah they are trying to incorporate the newly created database with an old used system to track leave. Command wants a 1 stop shop instead of having to input the leave data into 2 different locations. It is causing me a headache.
 
Last piece I need to finish this document. I need a way to pull the data from my rsLeave and put it into the spreadsheet. It needs to have the start date and end date of the leave as well as the space between all shaded and merged.

Code: 
    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 x As Long
    
    
'    'Set variables
    Set xlApp = CreateObject("Excel.Application")
    Set xlWB = xlApp.Workbooks.Add
    xlApp.Visible = True
    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)

    For x = 1 To 12
        rsRoster.MoveFirst
        Set wsNew = xlWB.Worksheets.Add(after:=xlWB.Worksheets(xlWB.Worksheets.Count))
        wsNew.Name = MonthName(x)
        wsNew.Range("D:AH").ColumnWidth = "10"
        wsNew.Cells(3, 1).Value = "DoD ID"
        wsNew.Cells(3, 2).Value = "Last Name"
        wsNew.Cells(3, 3).Value = "First Name"
        wsNew.Columns("A").ColumnWidth = "10"
        wsNew.Columns("B").ColumnWidth = "15"
        wsNew.Columns("C").ColumnWidth = "15"
        wsNew.Cells(2, 4).Value = "1"
        wsNew.Cells(2, 4).HorizontalAlignment = xlVAlignCenter
        wsNew.Cells(2, 5).Value = "2"
        wsNew.Cells(2, 5).HorizontalAlignment = xlVAlignCenter
        With wsNew.Range("A1", "C2")
            .MergeCells = True
            .Interior.ColorIndex = 16
        End With
        With wsNew.Range("A3", "C3")
            .HorizontalAlignment = xlVAlignCenter
            .Font.Bold = True
            .Font.Size = 14
        End With
        wsNew.Cells(4, 1).CopyFromRecordset rsRoster
        wsNew.Columns("D").Select
        xlApp.ActiveWindow.FreezePanes = True
        Select Case wsNew.Name
            Case "January", "March", "May", "July", "August", "October", "December"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AH2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AH1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    If wsNew.Name = "January" Then
                        .Value = "January"
                        wsNew.Cells(3, 4).Value = "Saturday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AH3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "March" Then
                        .Value = "March"
                        wsNew.Cells(3, 4).Value = "Tuesday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AH3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "May" Then
                        .Value = "May"
                        wsNew.Cells(3, 4).Value = "Sunday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AH3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "July" Then
                        .Value = "July"
                        wsNew.Cells(3, 4).Value = "Friday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AH3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "August" Then
                        .Value = "August"
                        wsNew.Cells(3, 4).Value = "Monday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AH3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "October" Then
                        .Value = "October"
                        wsNew.Cells(3, 4).Value = "Saturday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AH3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "December" Then
                        .Value = "December"
                        wsNew.Cells(3, 4).Value = "Thursday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AH3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    End If
                End With
            Case "April", "June", "September", "November"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AG2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AG1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    If wsNew.Name = "April" Then
                        .Value = "April"
                        wsNew.Cells(3, 4).Value = "Friday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AG3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "June" Then
                        .Value = "June"
                        wsNew.Cells(3, 4).Value = "Wednesday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AG3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "September" Then
                        .Value = "September"
                        wsNew.Cells(3, 4).Value = "Thursday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AG3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    ElseIf wsNew.Name = "November" Then
                        .Value = "November"
                        wsNew.Cells(3, 4).Value = "Tuesday"
                        wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AG3"), Type:=xlFillWeekdays
                        With wsNew.Range("D3", "AH3")
                            .HorizontalAlignment = xlVAlignCenter
                        End With
                    End If
                End With
            Case "February"
                wsNew.Range("D2:E2").Autofill Destination:=wsNew.Range("D2:AE2"), Type:=xlFillSeries
                With wsNew.Range("D1", "AE1")
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlVAlignCenter
                    .HorizontalAlignment = xlVAlignCenter
                    .MergeCells = True
                    .Value = "February"
                    wsNew.Cells(3, 4).Value = "Tuesday"
                    wsNew.Range("D3").Autofill Destination:=wsNew.Range("D3:AH3"), Type:=xlFillWeekdays
                    With wsNew.Range("D3", "AE3")
                        .HorizontalAlignment = xlVAlignCenter
                    End With
                End With
        End Select
        For Each rng In wsNew.Range("D3:AH3")
            With rng
                If rng.Value = "Saturday" Then
                    wsNew.Columns(.Column).Interior.ColorIndex = 16
                ElseIf rng.Value = "Sunday" Then
                    wsNew.Columns(.Column).Interior.ColorIndex = 16
                End If
            End With
        Next
    Next x
    rsRoster.Close
    rsLeave.Close
    Set rsRoster = Nothing
    Set rsLeave = Nothing
 
you can refer to recordset columns like this:

something=rsLeave.fields("fieldname").value

wrap in NZ if a null is possible
 
Capture.PNG

this is what the spreadsheet looks like.
Like say someone has leave from the 5th - 10th. I want to grab that ID # and shade in those days on the spreadsheet. How do I find that specific column on the right months sheet?
 
You must log in or register to reply here.

Similar threads

oxicottin
Solved Export search form data to excel
Replies
11
Views
872
oxicottin
oxicottin
S
Exporting to Excel .xlsx
Replies
8
Views
1,315
The_Doc_Man
The_Doc_Man
S
sdell
Replies
3
Views
1,156
pbaldy
pbaldy
C
Solved Is there a way to "copy" values in a subform to a new record.
Replies
10
Views
1,134
Pat Hartman
P
D
Excel commands through Access
Replies
7
Views
990
June7
June7

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom