VBA Code Needed

N

nhbartos

Board Regular
Joined
May 23, 2015
Messages
148
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]
 
Sort by date Sort by votes
Try the code re-modified:-
NB:- The previous code I sent was not working correctly, so I have modified it by adding a new "Sub" to delete blank columns over the 12 possible Month in the "Medicaid" sheets, hope that works for you.
I have also reduced the types of leave to 4 in the "Clients" as you will see, and removed the "Discharge" row.
Code: 
'[COLOR="Green"][B].New code 4/4/17 Modified 26/5/17[/B][/COLOR]
[COLOR="Navy"]Sub[/COLOR] StuUpdate()
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] sht [COLOR="Navy"]As[/COLOR] Worksheet, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] S [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] Variant, V [COLOR="Navy"]As[/COLOR] Variant, H [COLOR="Navy"]As[/COLOR] Variant, Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, Dn [COLOR="Navy"]As[/COLOR] Range, NumLog [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
NumLog = 14
Sheets("Medicaid").Cells.ClearContents
Call ****(Sheets("medicaid"))
Application.ScreenUpdating = False
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[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]
         Ray = sht.UsedRange
          
          [COLOR="Navy"]For[/COLOR] n = 4 To UBound(Ray, 1)
             [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
                    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"
                    
                    '[COLOR="Green"][B]##ReDim V(1 To 1500): V(1) = "Vacation Days"[/B][/COLOR]
                    '[COLOR="Green"][B]##ReDim H(1 To 1500): H(1) = "Half Days"[/B][/COLOR]
                    ReDim A(1 To 1500): A(1) = "Absent"
                   
                   '[COLOR="Green"][B] Dic.Add Ray(n, 1), Array(S, 1, E, 1, L, 1, V, 1, H, 1, A, 1)[/B][/COLOR]
                    
                    '[COLOR="Green"][B]New line[/B][/COLOR]
                    Dic.Add Ray(n, 1), Array(S, 1, E, 1, L, 1, A, 1)
                    Q = Dic(Ray(n, 1))
                    [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
                        [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
                            [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] UCase(Ray(n, Ac))
                                [COLOR="Navy"]Case[/COLOR] "S": Q(1) = Q(1) + 1: Q(0)(Q(1)) = Dt(sht, CLng(Ray(3, Ac)))
                                [COLOR="Navy"]Case[/COLOR] "E": Q(3) = Q(3) + 1: Q(2)(Q(3)) = Dt(sht, CLng(Ray(3, Ac)))
                                [COLOR="Navy"]Case[/COLOR] "L": Q(5) = Q(5) + 1: Q(4)(Q(5)) = Dt(sht, CLng(Ray(3, Ac)))
                                '[COLOR="Green"][B]Case "V": Q(7) = Q(7) + 1: Q(6)(Q(7)) = Dt(sht, CLng(Ray(3, Ac)))[/B][/COLOR]
                                '[COLOR="Green"][B]Case "H": Q(9) = Q(9) + 1: Q(8)(Q(9)) = Dt(sht, CLng(Ray(3, Ac)))[/B][/COLOR]
                                '[COLOR="Green"][B]Case "A": Q(11) = Q(11) + 1: Q(10)(Q(11)) = Dt(sht, CLng(Ray(3, Ac)))[/B][/COLOR]
                                '[COLOR="Green"][B]###New Line[/B][/COLOR]
                                [COLOR="Navy"]Case[/COLOR] "A": Q(7) = Q(7) + 1: Q(6)(Q(7)) = Dt(sht, CLng(Ray(3, Ac)))
                            [COLOR="Navy"]End[/COLOR] Select
                        [COLOR="Navy"]End[/COLOR] If
                    [COLOR="Navy"]Next[/COLOR] Ac
                  Dic(Ray(n, 1)) = Q
            [COLOR="Navy"]Else[/COLOR]
                    Q = Dic(Ray(n, 1))
                    [COLOR="Navy"]For[/COLOR] Ac = 2 To UBound(Ray, 2)
                        [COLOR="Navy"]If[/COLOR] Not IsEmpty(Ray(n, Ac)) [COLOR="Navy"]Then[/COLOR]
                            [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] UCase(Ray(n, Ac))
                             [COLOR="Navy"]Case[/COLOR] "S": Q(1) = Q(1) + 1: Q(0)(Q(1)) = Dt(sht, CLng(Ray(3, Ac)))
                             [COLOR="Navy"]Case[/COLOR] "E": Q(3) = Q(3) + 1: Q(2)(Q(3)) = Dt(sht, CLng(Ray(3, Ac)))
                             [COLOR="Navy"]Case[/COLOR] "L": Q(5) = Q(5) + 1: Q(4)(Q(5)) = Dt(sht, CLng(Ray(3, Ac)))
'[COLOR="Green"][B]                             Case "V": Q(7) = Q(7) + 1: Q(6)(Q(7)) = Dt(sht, CLng(Ray(3, Ac)))[/B][/COLOR]
'[COLOR="Green"][B]                             Case "H": Q(9) = Q(9) + 1: Q(8)(Q(9)) = Dt(sht, CLng(Ray(3, Ac)))[/B][/COLOR]
'[COLOR="Green"][B]                             Case "A": Q(11) = Q(11) + 1: Q(10)(Q(11)) = Dt(sht, CLng(Ray(3, Ac)))[/B][/COLOR]
                            '[COLOR="Green"][B]###new line[/B][/COLOR]
                            [COLOR="Navy"]Case[/COLOR] "A": Q(7) = Q(7) + 1: Q(6)(Q(7)) = Dt(sht, CLng(Ray(3, Ac)))
                            [COLOR="Navy"]End[/COLOR] Select
                        [COLOR="Navy"]End[/COLOR] If
                    [COLOR="Navy"]Next[/COLOR] Ac
                  Dic(Ray(n, 1)) = Q
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
    
    
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] sht
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] t, y [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Tot [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
 cc = 0
 [COLOR="Navy"]If[/COLOR] Not K = "" [COLOR="Navy"]Then[/COLOR]
  [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]Resume[/COLOR] [COLOR="Navy"]Next[/COLOR]
    [COLOR="Navy"]Set[/COLOR] sht = ActiveWorkbook.Sheets(K)
    [COLOR="Navy"]If[/COLOR] Not Err = 0 [COLOR="Navy"]Then[/COLOR]
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = K
    [COLOR="Navy"]End[/COLOR] If
 '[COLOR="Green"][B]Change Position of text and Alignment[/B][/COLOR]
 '[COLOR="Green"][B]to suit Between Bands Hash bands[/B][/COLOR]
 '[COLOR="Green"][B]###############[/B][/COLOR]
   [COLOR="Navy"]Dim[/COLOR] nNam [COLOR="Navy"]As[/COLOR] Range
   [COLOR="Navy"]With[/COLOR] Sheets(K)
    [COLOR="Navy"]Set[/COLOR] nNam = Studata(K): oMax = 0
    .Range("A7").Resize(500, 100).ClearContents
    .Range("C13") = K '[COLOR="Green"][B] This is Student Name, remove if not wanted[/B][/COLOR]
    .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("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
 '[COLOR="Green"][B]##########[/B][/COLOR]
       ReDim Ray(1 To 366, 1 To 2): y = 0
         Ray(1, 1) = K
         For n = 0 To 6 Step 2 '[COLOR="Green"][B]### was 10 step 2' added items from dict Now 10 was 7[/B][/COLOR]
            cc = cc + 1
            oMax = Application.Max(oMax, Dic(K)(n + 1))
            [COLOR="Navy"]For[/COLOR] c = 1 To Dic(K)(n + 1)
               
               '[COLOR="Green"][B]Sheets("July_2016").Cells(c + 18, cc + 1) = Dic(K)(n)(c)[/B][/COLOR]
               Sheets(K).Cells(c + 19, cc).Value = Dic(K)(n)(c) '[COLOR="Green"][B]NB:- Start Od Dates shown Here as C+18[/B][/COLOR]
               Sheets(K).Cells(c + 19, cc).NumberFormat = "M/d/yyyy"
            [COLOR="Navy"]If[/COLOR] c > 1 [COLOR="Navy"]Then[/COLOR]
            y = y + 1
            Ray(y, 2) = Dic(K)(n)(c)
            [COLOR="Navy"]End[/COLOR] If
            oMax = Application.Max(oMax, c)
            [COLOR="Navy"]Next[/COLOR] c
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]If[/COLOR] .Range("c15").Value = "Yes" [COLOR="Navy"]Then[/COLOR] 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 4  '[COLOR="Green"][B]##was 6[/B][/COLOR]
            .Cells(oMax + 21, Ac) = Application.CountA(.Cells(21, Ac).Resize(oMax))
            .Cells(oMax + 21, Ac).NumberFormat = "0"
    [COLOR="Navy"]Next[/COLOR] Ac
   [COLOR="Navy"]End[/COLOR] With
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
Call ColDel
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Function Dt(sh [COLOR="Navy"]As[/COLOR] Object, Num [COLOR="Navy"]As[/COLOR] Long) [COLOR="Navy"]As[/COLOR] Date
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]For[/COLOR] n = 1 To 12
    [COLOR="Navy"]If[/COLOR] MonthName(n) = Split(sh.Name, "_")(0) [COLOR="Navy"]Then[/COLOR]
        Dt = DateSerial(Split(sh.Name, "_")(1), n, Num)
        [COLOR="Navy"]Exit[/COLOR] For
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] Function

[COLOR="Navy"]Sub[/COLOR] ****(sht [COLOR="Navy"]As[/COLOR] Object)
[COLOR="Navy"]Dim[/COLOR] Pic [COLOR="Navy"]As[/COLOR] Picture, Fd [COLOR="Navy"]As[/COLOR] Boolean, nPic [COLOR="Navy"]As[/COLOR] Shape
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Pic [COLOR="Navy"]In[/COLOR] sht.Pictures
    Fd = True
[COLOR="Navy"]Next[/COLOR] Pic
[COLOR="Navy"]If[/COLOR] Not Fd [COLOR="Navy"]Then[/COLOR]
    Application.ScreenUpdating = False
    [COLOR="Navy"]Set[/COLOR] nPic = Sheets("Pic").Shapes("Picture 1")
    nPic.Copy
    [COLOR="Navy"]With[/COLOR] sht.Range("A1")
        .PasteSpecial
        nPic.Top = .Top '[COLOR="Green"][B] NB The Object is "Pic" not Picture !![/B][/COLOR]
        nPic.Left = .Left
        '[COLOR="Green"][B]Pic.LockAspectRatio = msoTrue ' I found when this was Locked I could not change the Picture size !!![/B][/COLOR]
        nPic.Height = 80
    [COLOR="Navy"]End[/COLOR] With
    Application.ScreenUpdating = True
[COLOR="Navy"]Else[/COLOR]
    [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Function Studata(Nam [COLOR="Navy"]As[/COLOR] Variant) [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]With[/COLOR] Sheets("Base Info")
[COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Dn.Value = Nam [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Studata = Dn
        [COLOR="Navy"]Exit[/COLOR] For
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] Function
[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]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, nSp [COLOR="Navy"]As[/COLOR] Variant, sht [COLOR="Navy"]As[/COLOR] Worksheet
[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]
  .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))
  [COLOR="Navy"]If[/COLOR] Dic(Mths(m))(1) > 1 [COLOR="Navy"]Then[/COLOR] .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"
  [COLOR="Navy"]End[/COLOR] If
[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]
[COLOR="Navy"]Sub[/COLOR] ColDel()
[COLOR="Navy"]Dim[/COLOR] Del [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Medicaid")
    [COLOR="Navy"]For[/COLOR] Del = 13 To 2 [COLOR="Navy"]Step[/COLOR] -1
        [COLOR="Navy"]If[/COLOR] Application.CountA(.Columns(Del)) = 0 [COLOR="Navy"]Then[/COLOR]
            .Columns(Del).EntireColumn.Delete
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Del
 .Range("A8").Value = "Medicaid Student Absences / All Types"
 .Range("A8:e8").Merge
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Hi Mick,
Thanks so much.

I replaced the entire code with what you sent, but got an error on Line 8: Call ****(Sheets("medicaid"))
 
Upvote 0
<code class="txt" style="margin: 0px; padding: 0px; box-sizing: border-box !important;">Hi Mick G:

I apologize for asking again, but I have been trying to make a requested change to the code for the last couple of weeks, with no luck. I am stuck, mind helping?

I have been asked to have ONLY (A) Absences and (S)Sick show up on the MEDICAID Tab.

All entry codes are to remain on the individual student reports.

The last code you sent me was in this link, and it is still there.

Do you mind?


https://app.box.com/s/ocwt0ave4m2ubje6dp6ilbsdqrpani7f
</code>
 
Upvote 0
You must log in or register to reply here.

Similar threads

zoharb
  • Question Question
networkdays.intl in excel 2007
Replies
2
Views
283
MARK858
MARK858
F
  • Solved
How to change value from data validation based on value in col A?
Replies
5
Views
330
Eric W
Eric W
D
  • Question Question
Count days at work that were fridays
Replies
3
Views
111
Dave Patton
D
J
  • Solved
Formula Filled Dates
Replies
4
Views
477
Fluff
Fluff
K
  • Question Question
Advice on Data Set up to Chart for Ongoing Daily Metrics
Replies
0
Views
170
Kolchak74
K

Forum statistics

Threads
1,223,721
Messages
6,174,096
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top