VBA Code Modification Needed

nhbartos · Jul 25, 2017

Hi folks,

A fellow forum user wrote this code for me and is no longer available.
I need a modification and hope somebody can make sense of this code and help me out.

THE ONLY change I need is:

On the "Medicaid" tab, I need only two absence code dates to populate on this page.
They are (A) Absent, and (S) Sick.
The remaining four codes should not appear.

*All dates for all codes should continue to populate on the individual student reports, and should not be affected by this change.

Code:

'.New code 4/4/17
Sub 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 2")
    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)
'R Holds Sick Dates,nn = number off,NL = Row Start for Medicaid results
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, nCol As Long ' nCol Added !!!
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 = 9 'Altered from 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))
 
 If Dic.exists(Mths(m)) Then 'Added Line !!!!
  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))
  If Dic(Mths(m))(1) > 1 Then .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 'added Line !!!!
'Below Code, Replaced by above !!!!!
'  .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))
'  If Dic(Mths(m))(1) > 1 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 'added Line !!!!
End If
Next m
.Columns.AutoFit
End With
nl = nl + oMax + 1
End Sub

MickG · Jul 25, 2017

I'm sorry I have not got back to you , but I inadvertently deleted you PM.
This code was some time ago, and quite extensive.
Without a good lead it could take a bit to sort.
To resolve you problem I would like a copy of the active file (Names change for privacy) and a note reflecting the page for update and an example showing what you want to keep and what you want removed.
Perhaps you could colour the cells effected accordingly "Keep (Green)" / "Remove (Red)" or similar.

nhbartos · Jul 25, 2017

Hello,
No need to apologize. I assumed you had enough and I don't blame you

But, thanks for getting in touch!

Ok, here is the link to the file: Attendance_2017-2018_Test.xlsm - Google Drive

I entered all codes, two times, for student 2 in July 2017.

Currently, we have the dates for all of these codes also populating the "Medicaid" tab.
I only want (S) Sick, and (A) Absent dates showing up on the "Medicaid" tab.
The other four should not show up.

On the "Medicaid" tab, I highlighted the dates that are to remain, GREEN (A) and (S) only.
All the RED, (E) (L) (V) (H) should no longer appear.

I still want all dates for all codes to continue to appear on the individual student reports. This is working perfectly.

I hope this is clear. Thanks much!!!!

MickG · Jul 26, 2017

Try this code modification.
Alter codes "StuUpdate" and "Medic" where shown in Red and marked :-##############
Hopefully this will give you what you want !!!

Code:

'.New code 4/4/17
'Modified 26/7/17
Sub 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
 
    [B]  [COLOR=#ff0000] ReDim Ray(1 To 366, 1 To 3): y = 0[/COLOR] 'Changed(1 to 2)  to (1 to 3)'#########################[/B]
         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)
            'If K = "Student 2" Then Stop
               '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)
           [B][COLOR=#ff0000] Ray(y, 3) = cc [/COLOR]' Line added'#########################[/B]
            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 2")
    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)
'R Holds Sick Dates,nn = number off,NL = Row Start for Medicaid results
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, nCol As Long ' nCol Added !!!
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For n = 1 To nn
[B]  [COLOR=#ff0000] If r(n, 3) = 1 Or r(n, 3) = 6 Then [/COLOR]'Line addedd @############################[/B]
    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
[B][COLOR=#ff0000]End If ' Line added '[/COLOR]############################[COLOR=#ff0000][/COLOR][/B]
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 = 9 'Altered from 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))
 
 If Dic.exists(Mths(m)) Then 'Added Line !!!!
  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))
  If Dic(Mths(m))(1) > 1 Then .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 'added Line !!!!
'Below Code, Replaced by above !!!!!
'  .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))
'  If Dic(Mths(m))(1) > 1 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 'added Line !!!!
End If
Next m
.Columns.AutoFit
End With
nl = nl + oMax + 1
End Sub

Nonprof · Jul 26, 2017

Hi MickG:

Thank you!

I replaced my entire code with what you returned, but got a compile error, Syntax error, line 9.

MickG · Jul 27, 2017

This is my the working copy of the modified file:-
https://app.box.com/s/tezf0cssh20o8c8ntccc13zl6kukewt4

VBA Code Modification Needed

nhbartos

Board Regular

Excel Facts

MickG

MrExcel MVP

nhbartos

Board Regular

MickG

MrExcel MVP

Nonprof

New Member

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

VBA Code Modification Needed

nhbartos

Board Regular

Excel Facts

MickG

MrExcel MVP

nhbartos

Board Regular

MickG

MrExcel MVP

Nonprof

New Member

MickG

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock