VBA Code Needed

[nhbartos]

Hi folks,

I have a table to track Personal, sick, vacation and half days taken for 25 to 150 students.
They are recorded by placing an "S", "P", "V", or an "H" in the cells for the corresponding date.
There is a different tab for each month.
School year July 1 2016 to June 30 2017.

I would like some code to pull the dates for all category entries, for each month, then place them in a table within each students reporting tab and sorted by date.
Below is a partial July 2016 table.
[TABLE="width: 1011"]
<colgroup><col><col span="31"></colgroup><tbody>[TR]
[TD]July[/TD]
[TD="colspan: 31"]Dates of Absence[/TD]
[/TR]
[TR]
[TD]Fri[/TD]
[TD]Sat[/TD]
[TD]Sun[/TD]
[TD]Mon[/TD]
[TD]Tue[/TD]
[TD]Wed[/TD]
[TD]Thu[/TD]
[TD]Fri[/TD]
[TD]Sat[/TD]
[TD]Sun[/TD]
[TD]Mon[/TD]
[TD]Tue[/TD]
[TD]Wed[/TD]
[TD]Thu[/TD]
[TD]Fri[/TD]
[TD]Sat[/TD]
[TD]Sun[/TD]
[TD]Mon[/TD]
[TD]Tue[/TD]
[TD]Wed[/TD]
[TD]Thu[/TD]
[TD]Fri[/TD]
[TD]Sat[/TD]
[TD]Sun[/TD]
[TD]Mon[/TD]
[TD]Tue[/TD]
[TD]Wed[/TD]
[TD]Thu[/TD]
[TD]Fri[/TD]
[TD]Sat[/TD]
[TD]Sun[/TD]
[/TR]
[TR]
[TD]Student Name[/TD]
[TD]1[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD]11[/TD]
[TD]12[/TD]
[TD]13[/TD]
[TD]14[/TD]
[TD]15[/TD]
[TD]16[/TD]
[TD]17[/TD]
[TD]18[/TD]
[TD]19[/TD]
[TD]20[/TD]
[TD]21[/TD]
[TD]22[/TD]
[TD]23[/TD]
[TD]24[/TD]
[TD]25[/TD]
[TD]26[/TD]
[TD]27[/TD]
[TD]28[/TD]
[TD]29[/TD]
[TD]30[/TD]
[TD]31[/TD]
[/TR]
[TR]
[TD]Student 1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 4[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 9[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 10[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 11[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 12[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Student 13

Is anyone able to help with this?

Vince[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[nhbartos]

Hi MickG:

Are you able to help me with the Medicaid tab code?

I am not sure what happened.

When a medicaid student has an absence during any month, July_2016 - June_2017, we created a Medicaid tab and those months/dates would be inserted.

If you recall, the first name appears in A14, B14 should have the first month with absences, and the dates absent should appear below the month. Blank months should not appear.

We just started using this in May 2017. We have un-used months July 2016 to April 2017. These are blank. So, we had the first month with codes entered to appear in column B, the next month in C, and so on...

I updated the form and the following occurred:

1. The first student name with an absence appeared in A14. Perfect.

2. But, the absence month "May_2017" appeared in column L, not column B as is was before. Remember, we didn't use months July 2016 to April 2017. Initially blank months/no absences were to NOT show up, but now it seems that it has blank columns for those un-used months, and May 2017 is now on the 2nd page to the right.

3. May_2017 now appears in L13 and L14. It now shows twice. It should only be in L14, or actually B14 if all the blank columns were not there.

4. I entered an absence code on June 12th to test the sheet. But, the date populated the cell above the month, in row 13, not 15 below the month.

We had the Student names in column A, then each month with absences to the right, and we had the columns auto width so we had the name and all 12 months on a single page width.

I hope I made sense here, and I hope you recall this and am willing to help.

Here is the entire code as we left it is now.

'.New code 4/4/17Sub StuUpdate()
Dim Ray As Variant, n As Long, sht As Worksheet, Ac As Long, Num As Long
Dim S As Variant, P As Variant, V As Variant, H As Variant, Q As Variant
Dim Dic As Object, Dn As Range, NumLog As Long
NumLog = 14
Sheets("Medicaid").Cells.ClearContents
Call ****(Sheets("medicaid"))
Application.ScreenUpdating = False
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each sht In Worksheets
    If InStr(sht.Name, "_") > 0 Then
         Ray = sht.UsedRange
          'MsgBox sht.UsedRange.Address
          For n = 4 To UBound(Ray, 1)
             If Not Dic.exists(Ray(n, 1)) Then
                    ReDim S(1 To 1500): S(1) = "Sick Days"
                    ReDim E(1 To 1500): E(1) = "Early Leave Days"
                    ReDim L(1 To 1500): L(1) = "Late Arrival Days"
                    ReDim V(1 To 1500): V(1) = "Vacation Days"
                    ReDim H(1 To 1500): H(1) = "Half Days"
                    ReDim A(1 To 1500): A(1) = "Absent"
                    Dic.Add Ray(n, 1), Array(S, 1, E, 1, L, 1, V, 1, H, 1, A, 1)
                    Q = Dic(Ray(n, 1))
                    For Ac = 2 To UBound(Ray, 2)
                        If Not IsEmpty(Ray(n, Ac)) Then
                            Select Case UCase(Ray(n, Ac))
                                Case "S": Q(1) = Q(1) + 1: Q(0)(Q(1)) = Dt(sht, CLng(Ray(3, Ac)))
                                Case "E": Q(3) = Q(3) + 1: Q(2)(Q(3)) = Dt(sht, CLng(Ray(3, Ac)))
                                Case "L": Q(5) = Q(5) + 1: Q(4)(Q(5)) = Dt(sht, CLng(Ray(3, Ac)))
                                Case "V": Q(7) = Q(7) + 1: Q(6)(Q(7)) = Dt(sht, CLng(Ray(3, Ac)))
                                Case "H": Q(9) = Q(9) + 1: Q(8)(Q(9)) = Dt(sht, CLng(Ray(3, Ac)))
                                Case "A": Q(11) = Q(11) + 1: Q(10)(Q(11)) = Dt(sht, CLng(Ray(3, Ac)))
                            End Select
                        End If
                    Next Ac
                  Dic(Ray(n, 1)) = Q
            Else
                    Q = Dic(Ray(n, 1))
                    For Ac = 2 To UBound(Ray, 2)
                        If Not IsEmpty(Ray(n, Ac)) Then
                            Select Case UCase(Ray(n, Ac))
                             Case "S": Q(1) = Q(1) + 1: Q(0)(Q(1)) = Dt(sht, CLng(Ray(3, Ac)))
                             Case "E": Q(3) = Q(3) + 1: Q(2)(Q(3)) = Dt(sht, CLng(Ray(3, Ac)))
                             Case "L": Q(5) = Q(5) + 1: Q(4)(Q(5)) = Dt(sht, CLng(Ray(3, Ac)))
                             Case "V": Q(7) = Q(7) + 1: Q(6)(Q(7)) = Dt(sht, CLng(Ray(3, Ac)))
                             Case "H": Q(9) = Q(9) + 1: Q(8)(Q(9)) = Dt(sht, CLng(Ray(3, Ac)))
                             Case "A": Q(11) = Q(11) + 1: Q(10)(Q(11)) = Dt(sht, CLng(Ray(3, Ac)))
                            End Select
                        End If
                    Next Ac
                  Dic(Ray(n, 1)) = Q
            End If
        Next n
    
    
    End If
Next sht
Dim K As Variant, c As Long, cc As Long, oMax As Long, Temp As String, Rw As Long, t, y As Long
Dim Tot As Long
For Each K In Dic.keys
 cc = 0
 If Not K = "" Then
  On Error Resume Next
    Set sht = ActiveWorkbook.Sheets(K)
    If Not Err = 0 Then
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = K
    End If
 'Change Position of text and Alignment
 'to suit Between Bands Hash bands
 '###############
   Dim nNam As Range
   With Sheets(K)
    Set nNam = Studata(K): oMax = 0
    .Range("A7").Resize(500, 100).ClearContents
    .Range("C13") = K ' This is Student Name, remove if not wanted
    .Range("A7") = Format(Now, "Mmmm,d,yyyy")
    .Range("A10").Value = "Student Attendance Record"
    .Range("A10:B10").Merge
    .Range("A7:B7").Merge
    .Range("A7").Font.Size = 16
    .Range("A7").Font.Bold = True
    .Range("A13").Value = "Student Name:"
   
    .Range("A14").Value = "Student ID:"
    .Range("A14:B14").Merge
    .Range("c14").Value = IIf(nNam.Offset(, 1) = "", "N/A", nNam.Offset(, 1))
    
     .Range("A15").Value = "Medicaid Student?"
     .Range("A15:B15").Merge
     .Range("c15").Value = IIf(nNam.Offset(, 2) = "", "No", nNam.Offset(, 2))


    
    .Range("A16").Value = "Date of Birth:"
    .Range("A16:B16").Merge
    .Range("c16").Value = IIf(CDate(nNam.Offset(, 3)) = "00:00:00", "", CDate(nNam.Offset(, 3)))
    
    .Range("A17").Value = "Admission Date:"
    .Range("A17:B17").Merge
    .Range("C17").Value = IIf(CDate(nNam.Offset(, 4)) = "00:00:00", "", CDate(nNam.Offset(, 4)))
    
    .Range("A18").Value = "Discharge Date:"
    .Range("A18:B18").Merge
    .Range("C18").Value = IIf(CDate(nNam.Offset(, 5)) = "00:00:00", "", CDate(nNam.Offset(, 5)))
    
    .Range("A7:b18").Font.Size = 12
    .Range("A7:b18").Font.Bold = True
    .Range("A13:A18").HorizontalAlignment = xlLeft
    .Range("A7").HorizontalAlignment = xlLeft
    .Range("c14:c18").HorizontalAlignment = xlLeft
 '##########
       ReDim Ray(1 To 366, 1 To 2): y = 0
         Ray(1, 1) = K
         For n = 0 To 10 Step 2 ' added items from dict Now 10 was 7
            cc = cc + 1
            oMax = Application.Max(oMax, Dic(K)(n + 1))
            For c = 1 To Dic(K)(n + 1)
               
               'Sheets("July_2016").Cells(c + 18, cc + 1) = Dic(K)(n)(c)
               Sheets(K).Cells(c + 19, cc).Value = Dic(K)(n)(c) 'NB:- Start Od Dates shown Here as C+18
               Sheets(K).Cells(c + 19, cc).NumberFormat = "M/d/yyyy"
            If c > 1 Then
            y = y + 1
            Ray(y, 2) = Dic(K)(n)(c)
            End If
            oMax = Application.Max(oMax, c)
            Next c
        Next n


If .Range("c15").Value = "Yes" Then Call medic(Ray, y, NumLog)
    .Columns("A:A").ColumnWidth = 13
   .Columns("B:B").ColumnWidth = 14
   .Columns("C:C").ColumnWidth = 14
   .Columns("D:D").ColumnWidth = 12
   .Columns("E:E").ColumnWidth = 12
   .Columns("F:F").ColumnWidth = 12
   .Range("A19").Resize(oMax + 18, 6).HorizontalAlignment = xlCenter
 
  Call ****(Sheets(K))
  Call Studata(K)


    For Ac = 1 To 6
            .Cells(oMax + 21, Ac) = Application.CountA(.Cells(21, Ac).Resize(oMax))
            .Cells(oMax + 21, Ac).NumberFormat = "0"
    Next Ac
   End With
 End If
Next K
Application.ScreenUpdating = True
End Sub
Function Dt(sh As Object, Num As Long) As Date
Dim n As Long
For n = 1 To 12
    If MonthName(n) = Split(sh.Name, "_")(0) Then
        Dt = DateSerial(Split(sh.Name, "_")(1), n, Num)
        Exit For
    End If
Next n
End Function




Sub ****(sht As Object)
Dim Pic As Picture, Fd As Boolean, nPic As Shape
For Each Pic In sht.Pictures
    Fd = True
Next Pic
If Not Fd Then
    Application.ScreenUpdating = False
    Set nPic = Sheets("Pic").Shapes("Picture 6")
    nPic.Copy
    With sht.Range("A1")
        .PasteSpecial
        nPic.Top = .Top ' NB The Object is "Pic" not Picture !!
        nPic.Left = .Left
        'Pic.LockAspectRatio = msoTrue ' I found when this was Locked I could not change the Picture size !!!
        nPic.Height = 80
    End With
    Application.ScreenUpdating = True
Else
    Exit Sub
End If
End Sub


Function Studata(Nam As Variant) As Range
Dim Rng As Range, Dn As Range
With Sheets("Base Info")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
For Each Dn In Rng
    If Dn.Value = Nam Then
        Set Studata = Dn
        Exit For
    End If
Next Dn
End Function
Sub medic(r As Variant, nn As Long, nl As Long)
Dim Dic As Object, n As Long, Q As Variant, Mths As Variant, m As Long, oMax As Long
Dim Sp As Variant, nSp As Variant, sht As Worksheet
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare


For n = 1 To nn
    If Not Dic.exists(Month(r(n, 2))) Then
        ReDim nray(1 To nn)
        nray(1) = CDbl(DateValue(r(n, 2)))
        Dic.Add Month(CDbl(DateValue(r(n, 2)))), Array(nray, 1)
    Else
        Q = Dic(Val(Month(r(n, 2))))
            Q(1) = Q(1) + 1
            Q(0)(Q(1)) = CDbl(DateValue((r(n, 2))))
         Dic(Val(Month(r(n, 2)))) = Q
    End If
Next n


Mths = Array(7, 8, 9, 10, 11, 12, 1, 2, 3, 4, 5, 6)
With Sheets("Medicaid")
   .Range("A8").Value = "Medicaid Student Absences / All Types"
   .Columns("A:m").ColumnWidth = 12
   .Range("A8:e8").Merge
   .Range("A8:e8").Font.Bold = True
   .Range("A8:e8").HorizontalAlignment = xlLeft
   .Range("A8:e8").Font.Size = 14
   .Range("b13:m13").Font.Bold = True
  


For m = 0 To UBound(Mths)
If Dic.exists(Mths(m)) Then
  For Each sht In Worksheets
    If InStr(sht.Name, "_") > 0 Then
        nSp = Split(sht.Name, "_")
        If nSp(0) = MonthName(Mths(m)) Then
           Sp = Split(sht.Name, "_")
           Exit For
        End If
    End If
  Next sht
  oMax = Application.Max(oMax, Dic(Mths(m))(1))
 
 
  .Cells(13, m + 2).Value = Left(Sp(0), 3) & "_" & Sp(1)
  .Cells(nl, 1).Value = r(1, 1)
  .Cells(nl, m + 2).Resize(Dic(Mths(m))(1)).Value = Application.Transpose(Dic(Mths(m))(0))
  .Cells(nl, m + 2).Resize(Dic(Mths(m))(1)).Sort .Cells(nl, m + 2), xlAscending
  .Cells(nl, m + 2).Resize(Dic(Mths(m))(1)).NumberFormat = "M/d/yyyy"
   




End If
Next m
.Columns.AutoFit
End With
nl = nl + oMax + 1
End Sub

Best,

Vince

 

[nhbartos]

This is how we had it set up:

[TABLE="class: cms_table_grid, width: 500, align: left"]
<tbody>[TR]
[TD]Medicaid Students[/TD]
[TD]Jul_2016[/TD]
[/TR]
[TR]
[TD]Student 1[/TD]
[TD]05/07/16[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]03/07/16[/TD]
[/TR]
[TR]
[TD]Student 2[/TD]
[TD]05/07/16[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]03/07/16[/TD]
[/TR]
[TR]
[TD]Student 3[/TD]
[TD]05/07/16[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]03/07/16[/TD]
[/TR]
[TR]
[TD]Student 4[/TD]
[TD]05/07/16[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]03/07/16[/TD]
[/TR]
[TR]
[TD]Student 5[/TD]
[TD]05/07/16[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]03/07/16[/TD]
[/TR]
</tbody>[/TABLE]

 

[MickG]

You will need to send the File (or good example) with the code.
This Thread was a some while ago and had a lot of Pages !!!!

 

[nhbartos]

Hi MickG:
I am not sure how else to get the file to you, but here is a link.
https://drive.google.com/file/d/0B1W8cwZVnTmPY3Z3UkNpZ051TDQ/view?usp=sharing

I added a "Discharged Tab", but ignore it, I am doing manually.

So the issue is with the Medicaid tab. You will see...

Thanks!

 

[MickG]

The basic problem seems to be that because you are using the month of "May" the results are in column "L",
This is because "May" is the 10 value in the "Mths" array in the function below.
(in the code this is column (10 +2))
The code is set up to position the Results based on the Month.
With your sheets set up as you have, it seems you don't have enough columns for all the months.
What are your thoughts ????

The other problem was that the date sort for each column was throwing a wobbly (Repositioning the dates & Headers) if there was only one date to sort.
I've amended the code for that .

Sub medic(r As Variant, nn As Long, nl As Long)
[COLOR=#008000]'R Holds Sick Dates,nn = number off,NL = Row Start for Medicaid results
[/COLOR]
Dim Dic As Object, n As Long, Q As Variant, Mths As Variant, m As Long, oMax As Long
Dim Sp As Variant, nSp As Variant, sht As Worksheet
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For n = 1 To nn
    If Not Dic.exists(Month(r(n, 2))) Then
        ReDim nray(1 To nn)
        nray(1) = CDbl(DateValue(r(n, 2)))
        Dic.Add Month(CDbl(DateValue(r(n, 2)))), Array(nray, 1)
    Else
        Q = Dic(Val(Month(r(n, 2))))
            Q(1) = Q(1) + 1
            Q(0)(Q(1)) = CDbl(DateValue((r(n, 2))))
         Dic(Val(Month(r(n, 2)))) = Q
    End If
Next n
[COLOR=#008000]'"Mths" array below":-  "May" = 5 = position 10 in Array (NB:- First position = 0)[/COLOR]
[COLOR=#008000]'Hence data for May is positioned in column 11.[/COLOR]
Mths = Array(7, 8, 9, 10, 11, 12, 1, 2, 3, 4, 5, 6)
With Sheets("Medicaid")
   .Range("A8").Value = "Medicaid Student Absences / All Types"
   .Columns("A:m").ColumnWidth = 12
   .Range("A8:e8").Merge
   .Range("A8:e8").Font.Bold = True
   .Range("A8:e8").HorizontalAlignment = xlLeft
   .Range("A8:e8").Font.Size = 14
   .Range("b13:m13").Font.Bold = True
  
For m = 0 To UBound(Mths)
If Dic.exists(Mths(m)) Then
  For Each sht In Worksheets
    If InStr(sht.Name, "_") > 0 Then
        nSp = Split(sht.Name, "_")
        If nSp(0) = MonthName(Mths(m)) Then
           Sp = Split(sht.Name, "_")
           Exit For
        End If
    End If
  Next sht
  oMax = Application.Max(oMax, Dic(Mths(m))(1))
 
 'NB:- "m" = column position +2
  .Cells(13, m + 2).Value = Left(Sp(0), 3) & "_" & Sp(1)
  .Cells(nl, 1).Value = r(1, 1)
  .Cells(nl, [COLOR=#FF0000]m + 2[/COLOR]).Resize(Dic(Mths(m))(1)).Value = Application.Transpose(Dic(Mths(m))(0))
[COLOR=#008000]  'Code line below amended[/COLOR]
 [COLOR=#FF0000]If Dic(Mths(m))(1) > 1 [/COLOR]Then .Cells(nl, m + 2).Resize(Dic(Mths(m))(1)).Sort .Cells(nl, m + 2), xlAscending
  .Cells(nl, m + 2).Resize(Dic(Mths(m))(1)).NumberFormat = "M/d/yyyy"
   

End If
Next m
.Columns.AutoFit
End With
nl = nl + oMax + 1
End Sub

 

[nhbartos]

When we had it set up initially, it was disregarding the empty months and aligning left, in column B, then is changed.

Is it possible to:
1. Have it skip the months with no absence dates and align to left? This is not going to be an issue however when the new school year starts in July. We will have every month with absence dates.
2 Insert the 13 required columns to keep the name and all 12 months on one page width? We can have the columns adjust to text size/width, and we/I can set the font to a size that would allow that. Horizontal pages are a problem, vertical is not. I would also be ok with setting this particular tab to landscape if that makes it easier...

Should I wait for updated code or is the above a separate issue?

Thanks!

 

[nhbartos]

I just noticed that the medicaid tab is already landscape, so lets squeeze the columns in...
Thanks MickG!

 

[MickG]

Try this Modification:-

[COLOR=navy]Sub[/COLOR] medic(r [COLOR=navy]As[/COLOR] Variant, nn [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] nl [COLOR=navy]As[/COLOR] Long)
'[COLOR=green][B]R Holds Sick Dates,nn = number off,NL = Row Start for Medicaid results[/B][/COLOR]
[COLOR=navy]Dim[/COLOR] Dic [COLOR=navy]As[/COLOR] Object, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant, Mths [COLOR=navy]As[/COLOR] Variant, m [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] oMax [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
Dim Sp As Variant, nSp As Variant, sht As Worksheet, nCol As Long '[COLOR=green][B] nCol Added !!![/B][/COLOR]
[COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] n = 1 To nn
    [COLOR=navy]If[/COLOR] Not Dic.exists(Month(r(n, 2))) [COLOR=navy]Then[/COLOR]
        ReDim nray(1 To nn)
        nray(1) = CDbl(DateValue(r(n, 2)))
        Dic.Add Month(CDbl(DateValue(r(n, 2)))), Array(nray, 1)
    [COLOR=navy]Else[/COLOR]
        Q = Dic(Val(Month(r(n, 2))))
            Q(1) = Q(1) + 1
            Q(0)(Q(1)) = CDbl(DateValue((r(n, 2))))
         Dic(Val(Month(r(n, 2)))) = Q
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] n
Mths = Array(7, 8, 9, 10, 11, 12, 1, 2, 3, 4, 5, 6)
[COLOR=navy]With[/COLOR] Sheets("Medicaid")
   .Range("A8").Value = "Medicaid Student Absences / All Types"
   .Columns("A:M").ColumnWidth = 9 '[COLOR=green][B]Altered from 12[/B][/COLOR]
   .Range("A8:e8").Merge
   .Range("A8:e8").Font.Bold = True
   .Range("A8:e8").HorizontalAlignment = xlLeft
   .Range("A8:e8").Font.Size = 14
   .Range("b13:m13").Font.Bold = True
  
[COLOR=navy]For[/COLOR] m = 0 To UBound(Mths)
[COLOR=navy]If[/COLOR] Dic.exists(Mths(m)) [COLOR=navy]Then[/COLOR]
  [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] sht [COLOR=navy]In[/COLOR] Worksheets
    [COLOR=navy]If[/COLOR] InStr(sht.Name, "_") > 0 [COLOR=navy]Then[/COLOR]
        nSp = Split(sht.Name, "_")
        [COLOR=navy]If[/COLOR] nSp(0) = MonthName(Mths(m)) [COLOR=navy]Then[/COLOR]
           Sp = Split(sht.Name, "_")
           [COLOR=navy]Exit[/COLOR] For
        [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
  [COLOR=navy]Next[/COLOR] sht
  oMax = Application.Max(oMax, Dic(Mths(m))(1))
 
 If Dic.exists(Mths(m)) Then '[COLOR=green][B]Added Line !!!![/B][/COLOR]
  nCol = nCol + 1
  .Cells(13, nCol + 1).Value = Left(Sp(0), 3) & "_" & Sp(1)
  .Cells(nl, 1).Value = r(1, 1)
  .Cells(nl, nCol + 1).Resize(Dic(Mths(m))(1)).Value = Application.Transpose(Dic(Mths(m))(0))
  [COLOR=navy]If[/COLOR] Dic(Mths(m))(1) > 1 [COLOR=navy]Then[/COLOR] .Cells(nl, nCol + 1).Resize(Dic(Mths(m))(1)).Sort .Cells(nl, nCol + 1), xlAscending
  .Cells(nl, nCol + 1).Resize(Dic(Mths(m))(1)).NumberFormat = "M/d/yyyy"
  End If '[COLOR=green][B]added Line !!!![/B][/COLOR]

'[COLOR=green][B]Below Code, Replaced by above !!!!![/B][/COLOR]
'[COLOR=green][B]  .Cells(13, m + 2).Value = Left(Sp(0), 3) & "_" & Sp(1)[/B][/COLOR]
'[COLOR=green][B]  .Cells(nl, 1).Value = r(1, 1)[/B][/COLOR]
'[COLOR=green][B]  .Cells(nl, m + 2).Resize(Dic(Mths(m))(1)).Value = Application.Transpose(Dic(Mths(m))(0))[/B][/COLOR]
'[COLOR=green][B]  If Dic(Mths(m))(1) > 1 Then .Cells(nl, m + 2).Resize(Dic(Mths(m))(1)).Sort .Cells(nl, m + 2), xlAscending[/B][/COLOR]
'[COLOR=green][B]  .Cells(nl, m + 2).Resize(Dic(Mths(m))(1)).NumberFormat = "M/d/yyyy"[/B][/COLOR]
'[COLOR=green][B]  End If 'added Line !!!![/B][/COLOR]

[COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] m
.Columns.AutoFit
[COLOR=navy]End[/COLOR] With
nl = nl + oMax + 1
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[nhbartos]

Perfect!
I wish I could thank you more than I have already...
Best.

 

[nhbartos]

Hi MickG...

I apologize for this.
We did everything I was asked to do, but my boss didn't think things through...

Hopefully, this shouldn't take much of your time at all.

1. Do you have time to remove (V) Vacations and (H) Half Days from appearing on the Medicaid tab and individual student reports? These are not really absences. I tried it, but could not get things to align properly.

On the individual student reports, they are in columns D and E. Absence should move left to column D.

2. Last thing...we no longer want the "Discharge" row and date to appear on any of the student tabs (Row 18). I am removing it from the Base Info tab.

Do you still have my most recent file?