Is there a better way?

so the macro uses interior.themecolor - why don't you try that instead of .backcolor?

Edit: in the code you provided, to shade the weekends you used

Code: 
'shade in the weekends
        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

which is another way (.Interior.ColorIndex) - you appear to have commented out the line that uses this
 
Last edited:
I did try that one still get the same error. After trying the ?wsNew(Month....... in the immediate window and then trying to slowly type out the code the pop up window doesn't pop up at the beginning when i hit .cells so I think it might be something in that opening series.
 
so far as I can see,

While Not rsLeave.EOF
rownum = rownum + 1
For i = 0 To DateDiff("d", rsLeave![Start Date], rsLeave![End Date])
initDate = rsLeave![Start Date]
xlWB(MonthName(initDate)).cells(rownum, Day(initDate + i)).BackColor = 4 ' is xlWB still in scope? is xlWB(MonthName(initDate)) still in scope?
'wsNew(MonthName(rsLeave![Start Date])).cell(rownum, Day(rsLeave![Start Date] + i)).BackColor = 4
'wsNew(Month(rsLeave![Start Date])).cells(rownum, Day(rsLeave![Start Date] + i)).BackColor = 4
'wsNew(Month(rsLeave![Start Date])).cells(rownum, Day(rsLeave![Start Date] + i)).Interior.ColorIndex = 4
Next i
rsLeave.MoveNext
Wend
Click to expand...
 
that was a failed attempt, I thought maybe the action required looking at the whole workbook instead of the sheets but alas that didnt work either got "Invalid procedure or argument" I also tried to put that whole loop up into the individual month creations but that was bad too.

Oh I also tried to put the [Start Date] into a variable to maybe ease the system but still same error.
 
suggest temporarily early bind your excel to get the intellisense (change the dim statements as well) then build the line up a step at a time.

You still don't answer the questions I ask but final hint - how did you create wsNew? it's in your code and you should understand it

So I suspect xlWB.worksheets(MonthName(initDate)) will work
 
I think i might have found what is really causing the problem. The first leave in the RS spans a few months so it cannot be put into the individual month sheets.

Code: 
    rownum = 1
    While Not rsLeave.EOF
        rownum = rownum + 1
        If (Month(rsLeave![Start Date])) < (Month(rsLeave![End Date])) Then
            Day(rsLeave!([End Date])) = Format(DateSerial(Year(Date), Month(Date) + 1, 0), "d")
        ElseIf (Month(rsLeave![Start Date])) > (Month(rsLeave![End Date])) Then
            Day(rsLeave!([Start Date])) = 1
        End If
        For i = 0 To DateDiff("d", rsLeave![Start Date], rsLeave![End Date])
            initDate = rsLeave![Start Date]
            xlWB.worksheets(MonthName(initDate)).cells(rownum, Day(initDate + i)).Interior.ColorIndex = 4
            'xlWB(MonthName(initDate)).cells(rownum, Day(initDate + i)).BackColor = 4
            'wsNew(MonthName(rsLeave![Start Date])).cells(rownum, Day(rsLeave![Start Date] + i)).Interior.ThemeColor = 4
            'wsNew(Month(rsLeave![Start Date])).cells(rownum, Day(rsLeave![Start Date] + i)).BackColor = 4
            'wsNew(Month(rsLeave![Start Date])).cells(rownum, Day(rsLeave![Start Date] + i)).Interior.ColorIndex = 4
        Next i
        rsLeave.MoveNext
    Wend

I tried adding an if statement to kinda cheat my way to fill each month. If the month of the start date is before the month of the end date then the day of the end date becomes the end of the month. If the month of the start date is......shit after typing this out thats not going to work. ok so it has to read if month(rsLeave![End Date]) is not current month then day is end of month. else if start date is not current month then start date is 1.

Code: 
        If (Month(rsLeave![End Date])) <> (Month(Date)) Then
            Day(rsLeave!([End Date])) = Format(DateSerial(Year(Date), Month(Date) + 1, 0), "d")
        ElseIf (Month(rsLeave![Start Date])) <> (Month(Date)) Then
            Day(rsLeave!([Start Date])) = 1
        End If

I am getting now a "Type-declaration character does not match declared data type" error. Highlighting the Day(rsLeave!([End Date]) part of the if statement.
 
crap no that's not going to work either since its checking on the current month and not the month tab that it is adding leave to.
 
try


Code: 
For i = 0 To DateDiff("d", rsLeave![Start Date], rsLeave![End Date])
            initDate = rsLeave![Start Date]
            if year(initdate)=year(initdate+i) then 'still in same year 
                xlWB.worksheets(MonthName(initDate+i)).cells(rownum, Day(initDate + i)).Interior.ColorIndex = 4
            else ' into next year so stop further formatting
                exit for
            end if
        Next i
 
ok yeah that works for the ones that go over a year but I think the main issue I am going to run into is if someone takes leave from say january 25 to february 14 being 1 month a sheet shading the proper cells is causing an error.

I know your going to hate me but I went back to a single sheet.

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

that is all my variable assignments and static values.
 
Code: 
      '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

setting each month on the sheet
 
Code: 
While Not rsLeave.EOF
        rownum = rownum + 1
        If Month(rsLeave![Start Date]) = 1 Then
            Set Mrng = xlSh.Range("CR4", "DV230")
        ElseIf Month(rsLeave![Start Date]) = 2 Then
            Set Mrng = xlSh.Range("DW4", "EX230")
        ElseIf Month(rsLeave![Start Date]) = 3 Then
            Set Mrng = xlSh.Range("EY4", "GC230")
        ElseIf Month(rsLeave![Start Date]) = 4 Then
            Set Mrng = xlSh.Range("GD4", "HG230")
        ElseIf Month(rsLeave![Start Date]) = 5 Then
            Set Mrng = xlSh.Range("HH4", "IL230")
        ElseIf Month(rsLeave![Start Date]) = 6 Then
            Set Mrng = xlSh.Range("IM4", "JP230")
        ElseIf Month(rsLeave![Start Date]) = 7 Then
            Set Mrng = xlSh.Range("JQ4", "KU230")
        ElseIf Month(rsLeave![Start Date]) = 8 Then
            Set Mrng = xlSh.Range("KV4", "LZ230")
        ElseIf Month(rsLeave![Start Date]) = 9 Then
            Set Mrng = xlSh.Range("MA4", "ND230")
        ElseIf Month(rsLeave![Start Date]) = 10 Then
            Set Mrng = xlSh.Range("D4", "AH230")
        ElseIf Month(rsLeave![Start Date]) = 11 Then
            Set Mrng = xlSh.Range("AI4", "BL230")
        ElseIf Month(rsLeave![Start Date]) = 12 Then
            Set Mrng = xlSh.Range("BM4", "CQ230")
        End If
        With Mrng
            For i = 0 To DateDiff("d", rsLeave![Start Date], rsLeave![End Date])
                xlSh.cells(rownum, Day(rsLeave![Start Date] + i)).Interior.ColorIndex = 4
            Next i
        End With
        rsLeave.MoveNext
    Wend
    rsLeave.Close
    xlWB.SaveAs filename:=filepath & "T2T as of " + Format(Date, "YYYYMMDD") & ".xlsx"
    Set rsRoster = Nothing
    Set rsLeave = Nothing

End Sub

the bottom. I am getting shading on the sheet just not were it is supposed to be.
I get an error "Application-defined or Objet-defined error" highlights
Code: 
xlSh.cells(rownum, Day(rsLeave![Start Date] + i)).Interior.ColorIndex = 4
 
you keep changing what I suggested - did you do it exactly as I showed you to define the sheet

xlWB.worksheets(MonthName(initDate+i))

When you are provided with code or get from the web you need to take a bit of time to understand what it is actually doing. And if I provide something and it does not do what you expect it to do - you need to show the effect, not just describe it

think I am going to have to leave it there, I have other commitments I need to turn my attention to.

Good luck
 
what is happening is the excel document is shading in cells but instead of finding the range that I have set for each month the shading starts at "A1" and just goes down the spreadsheet. Some reason the range that I have set in variable "Mrng" is not being followed.

Also I am getting the error "Application-defined or Object-defined error" highlighting the following line:
Code: 
xlSh.cells(rownum, Day(initDate + i)).Interior.ColorIndex = 4
 
I repeat - understand what your code is doing, step through the code and check values
 
So I have gone back through and made adjustments. I am not getting any errors anymore yet it is not quite doing what i want.
Code: 
    rownum = 4
    Do While rsLeave.EOF = False
        initDate = rsLeave![Start Date]
        rownum = rownum + 1
        i = DateDiff("d", rsLeave![Start Date], rsLeave![End Date])
        If Month(initDate) = 1 Then
            Set Mrng = xlSh.Range("CR4", "DV210")
        ElseIf Month(initDate) = 2 Then
            Set Mrng = xlSh.Range("DW4", "EX210")
        ElseIf Month(initDate) = 3 Then
            Set Mrng = xlSh.Range("EY4", "GC210")
        ElseIf Month(initDate) = 4 Then
            Set Mrng = xlSh.Range("GD4", "HG210")
        ElseIf Month(initDate) = 5 Then
            Set Mrng = xlSh.Range("HH4", "IL210")
        ElseIf Month(initDate) = 6 Then
            Set Mrng = xlSh.Range("IM4", "JP210")
        ElseIf Month(initDate) = 7 Then
            Set Mrng = xlSh.Range("JQ4", "KU210")
        ElseIf Month(initDate) = 8 Then
            Set Mrng = xlSh.Range("KV4", "LZ210")
        ElseIf Month(initDate) = 9 Then
            Set Mrng = xlSh.Range("MA4", "ND210")
        ElseIf Month(initDate) = 10 Then
            Set Mrng = xlSh.Range("D4", "AH210")
        ElseIf Month(initDate) = 11 Then
            Set Mrng = xlSh.Range("AI4", "BL210")
        ElseIf Month(initDate) = 12 Then
            Set Mrng = xlSh.Range("BM4", "CQ210")
        End If
        With Mrng
            xlSh.cells(rownum, Day(initDate + i)).Interior.ColorIndex = 4
        End With
        rsLeave.MoveNext
    Loop
Capture.PNG




as you can see single cells are being highlighted instead of initDate+i which should be a row of cells. Plus it is not taking into account the range that I have set up for the months, just starting at column A.
 
Please study and practice/learn how to use Immediate window and breakpoints to examine each line as it executes and see what the values are.
In the immediate window, while the code is in break mode on a given line, you can "ask" it questions, like these sample questions:

Code: 
?xlSh.name
?rownum
?initDate
?initDate+i
?xlSh.cells(rownum, Day(initDate + i)).address

The last one may be particularly revealing
 
so the whole immediate window thing with the ? terms doesn't work I get no answers nothing happens. I had to put a watch on the variable and look into that for the values. I have realized yesterday that rownum as was stated doesn't work since it just goes down the row 1 by 1 until the end and that's not what I want. I have been trying to add in a match or find to make the rownum variable the DoD ID from the RS. my most recent failure of this is:
Code: 
rownum = xlApp.xlSh.WorksheetFunction.Row(rsLeave![DoD ID])

once I get that to work I have to then find out why the if statements for my range variables aren't working.
 
Valentine said:
so the whole immediate window thing with the ? terms doesn't work I get no answers nothing happens. I had to put a watch on the variable and look into that for the values. I have realized yesterday that rownum as was stated doesn't work since it just goes down the row 1 by 1 until the end and that's not what I want. I have been trying to add in a match or find to make the rownum variable the DoD ID from the RS. my most recent failure of this is:
Code: 
rownum = xlApp.xlSh.WorksheetFunction.Row(rsLeave![DoD ID])

once I get that to work I have to then find out why the if statements for my range variables aren't working.
Click to expand...
If the immediate window doesn't give you any answers then you're either typing it wrong or the code is not in brake mode at the proper spot.
 
Valentine said:
rownum = xlApp.xlSh.WorksheetFunction.Row(rsLeave![DoD ID])
Click to expand...

Does this help..?

Code: 
Dim rRange As Range

Set rRange = xlSh.Cells.Find(What:=rsLeave![DoD ID], After:=ActiveCell, LookIn:= _
     xlFormulas2, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
     xlNext, MatchCase:=False, SearchFormat:=False)

rownum = rRange.Row
 
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