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
I can't really duplicate any of those errors !!
Below is a test file, basically the same but only 2 months.
Have a Play with this, add month , students, leave, Format etc. to find the problems, if you find any errors, Give me the details and I'll try to replicate at my end.
NB:- If you completely remove students from the "Months_Years" sheets, then you need to remove the Actual sheet relating to that student !!!

https://app.box.com/s/pwodqg75lu6saxuxru4tlbnudjf0rxcl
 
Upvote 0

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
MickG...

I can't explain it, but things are working pretty ok.
Not sure what happened, but the names on the tabs are remaining there.
The dates on the reports are updating now...
I don't get it.

Is there a specific process I have to follow when adding or deleting students/dates?

We are nearly finished! Do you mind helping with a few more things?

I need these reports to be ready to print off at any time, formatted, with no manipulation.

1. I would like the absences columns to fit the text and not truncate, and the headers/dates to center in the cells automatically.

2. I would like to get a header in there. Is this fairly easy to do?

a. On the report tabs, I want a header image, and text. Then the reports will be done.

Is it possible for you to put a dummy image and dummy text in for now?
I was hoping you can get it in there formatted and then tell me how to change out the image and text???
Possible?

IMAGE:
Header Left align: Insert image. My logo is 1" x "3 in the top left. I just want to make sure there is sufficient spacing between the header and the Student name, dob, etc...

TEXT:
Center align: Can you enter any text in there for now that I can modify later?
I would like the text a couple rows below the image so there is some space between them as well.


Image 1 x 3, left aligned


Text to be added and changed by
me "Admission List", center aligned




[TABLE="width: 102"]
<colgroup><col></colgroup><tbody>[TR]
[TD]Student Name:[/TD]
[/TR]
[TR]
[TD]DOB:[/TD]
[/TR]
[TR]
[TD]Admission Date:[/TD]
[/TR]
[TR]
[TD]Discharge Date:[/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Yeah, everything seems fine.
I must have been doing something wrong...

I think we will be good if you can help me with the other changes on the report...
 
Upvote 0
Below is the replacement code:-
To replace code:-
Inany sheet click "Alt+F11" ,Vbcodewindow appears.
Toshow "Project window" (if not showing) , click "Ctrl+R"
Scrolldown Project window until you see "Module2".
Doubleclick to show current code in Vbwindow.
Replacethat code with The new code below.
Halfway down the code you will see 2 sets of "#" hash lines.
Youcan now alter the code relating to the various cells before row 15 in each student sheet as required.
Soby just changing the cell addresse/formats you can place the basic"Student Sheet) data as you require.
Thelast sub at the bottom of the code window is "****" this code isfor attaching a picture/Logo (From File)to each of the student sheets.
Abouthalf way down "****" you will see a reference to a File path, youwill need to change this to the correct path relating to your actual Logo file.
NB:-The code is written so that only one picture can reside in each sheet, withoutthis, each time you run the code , a copy of the same picture would be added.
Soif you want to replace the Logo with another , at any time , you need to removethe existing pictures.
Furtherdown that code you will see reference to the Logo location (A1 in this case)and its size, Change the values/Position to suit.

NB:-I could not get the "Autofit" function to work properly for thecolumns , so I've set each of the first 5 columns individually. Alter these tosuit within the Hash lines.
IfI think of anything else , I'll let you know.
Important:- For some reason The line below the last Hash line should read :- Call **** (Sheets(K)) But the The name **** has been replaced by ****, not my doing !!!
NB:- All that code need to go in the same Basic Module "Module2"
Code: 
[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
[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 P(1 To 1500): P(1) = "Personal Days"
                    ReDim V(1 To 1500): V(1) = "Vacation Days"
                    ReDim H(1 To 1500): H(1) = "Half Days"
                   Dic.Add Ray(n, 1), Array(S, 1, P, 1, V, 1, H, 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] 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] "P": Q(3) = Q(3) + 1: Q(2)(Q(3)) = Dt(sht, CLng(Ray(3, Ac)))
                                [COLOR=navy]Case[/COLOR] "V": Q(5) = Q(5) + 1: Q(4)(Q(5)) = Dt(sht, CLng(Ray(3, Ac)))
                                [COLOR=navy]Case[/COLOR] "H": 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] 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] "P": Q(3) = Q(3) + 1: Q(2)(Q(3)) = Dt(sht, CLng(Ray(3, Ac)))
                             [COLOR=navy]Case[/COLOR] "V": Q(5) = Q(5) + 1: Q(4)(Q(5)) = Dt(sht, CLng(Ray(3, Ac)))
                              [COLOR=navy]Case[/COLOR] "H": 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]
Application.ScreenUpdating = False
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] Dic.keys
 [COLOR=navy]If[/COLOR] Not K = "" [COLOR=navy]Then[/COLOR]
 cc = 1
 [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]With[/COLOR] Sheets(K)
    .Range("A15").Resize(500, 100).ClearContents
    .Range("B5:B8").HorizontalAlignment = xlToRight
    .Range("c5") = K '[COLOR=green][B] This is Student Name, remove if not wanted[/B][/COLOR]
    .Range("B5").Value = "Student Name:"
    .Range("B6").Value = "DOB:"
    .Range("B7").Value = "Admission Date:"
    .Range("B8").Value = "Discharge Date:"
    .Range("A5") = "MyText"
    .Range("A5").HorizontalAlignment = xlCenter
 '[COLOR=green][B]##########[/B][/COLOR]
        [COLOR=navy]For[/COLOR] n = 0 To 7 [COLOR=navy]Step[/COLOR] 2
            cc = cc + 1
            oMax = Application.Max(oMax, Dic(K)(n + 1))
            [COLOR=navy]For[/COLOR] c = 1 To Dic(K)(n + 1)
                .Cells(c + 15, cc) = Dic(K)(n)(c)
            [COLOR=navy]Next[/COLOR] c
        [COLOR=navy]Next[/COLOR] n
  '[COLOR=green][B]############# Alter below as required[/B][/COLOR]
   .Columns("A:A").ColumnWidth = 15
   .Columns("B:B").ColumnWidth = 15
   .Columns("C:C").ColumnWidth = 15
   .Columns("D:D").ColumnWidth = 15
   .Columns("E:E").ColumnWidth = 15
   .Columns("F:F").ColumnWidth = 15
   .Range("A15").Resize(oMax + 15, 6).HorizontalAlignment = xlCenter
 '[COLOR=green][B]###################[/B][/COLOR]
  Call ****(Sheets(K))
  [COLOR=navy]End[/COLOR] With
 [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] K
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
Code: 
[COLOR=black][FONT=Calibri][COLOR=navy]
Sub s[/COLOR]Pic(sht [COLOR=navy]As[/COLOR] Object)
[COLOR=navy]Dim[/COLOR] Pic [COLOR=navy]As[/COLOR] Picture, Fd [COLOR=navy]As[/COLOR] Boolean
[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=green][B]Change path of your image to suit[/B][/COLOR]
    [COLOR=navy]Set[/COLOR] Pic = sht.Pictures.Insert("C:\Users\USER1\Desktop\thP2Y8R8D3.jpg")
    [COLOR=navy]With[/COLOR] sht.Range("A1")
        Pic.Top = .Top '[COLOR=green][B] This means The top of pic is aligned with top of "A1" etc.[/B][/COLOR]
        Pic.Left = .Left
        Pic.Height = .Height * 3
        '[COLOR=green][B]Pic.Width = .Width ' add if required[/B][/COLOR]
    [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]
[/FONT][/COLOR]

Regards Mick
 
Last edited:
Upvote 0
To Repeat:-
The forum page seems to be having some problems, so I'll repeat the following :-
Important:- For some reason The line below the last Hash line should read :- Call SP(Sheets(K)) But the he name that was there **** has been replaced by ****, not my doing !!!
Change the beginning of that sub name to SP and the SuB relating to it further down. Just make sure they both have the same Name.
So where you see :- Call ****(Sheets(K)) Change those **** to SP and also change the name of the Last sub for the pictures to SP.
This is getting to be a Pain !!!!!!!

NB:- All that code need to go in the same Basic Module "Module2"


To save on all the Hassle, here is a Text file with the correct Code:-
https://app.box.com/s/xmjxfa4nws60dfs39k7j4b2jbc1zff63

Sorry about this !!
 
Last edited:
Upvote 0
Hey MickG...

Excellent progress! Thanks!
The text code worked perfect :)


Ok, I modified the code and have attached it, below. Here is what I have done or am having issues with.

Updated Categories:

Sick Days "S"
Early Leave Days "E"
Late Arrival Days "L"
Vacation Days "V"
Half Days "H"
Late Arrival, Early Leave "M"

1. I started to modify the code for the absence categories and now have 6.

2. I deleted "P" Personal.

3. I added "M" = Late in Early Out.

4. The following categories are not showing up on the reports.

Half Days "H"
Late Arrival, Early Leave "M"

5. Shift categories left.

I want them to start in Column A, A through F. I couldn't figure it out.
Also need to make sure the report print area includes all 6 columns.

5. I added the date on line 67, and shifted things down.

So, we need to move the absence type headers from row 16 to row 19.
They will be in columns A:F, centered in column.

6. Line 75,76 of Module 2, won't fully align left. The code to align left in on line 79.


Module 1
Code: 
Sub Rndleave()' Code to produce random leave (Initials) for active sheet
Dim Ray, t As Variant, col As Long, Rw As Long, n As Long
Ray = Array("S", "E", "L", "V", "H", "M")
For Each t In Ray
    For n = 1 To 24
        col = Int(Rnd * 30) + 2
        Rw = Int(Rnd * 20) + 4
        Cells(Rw, col) = t
    Next n
Next t

End Sub



Module 2
Code: 
Dim Dic As ObjectSet Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each sht In Worksheets
    If InStr(sht.Name, "_") > 0 Then
         Ray = sht.UsedRange
          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 M(1 To 1500): M(1) = "Late In Early out"
                    Dic.Add Ray(n, 1), Array(S, 1, E, 1, L, 1, V, 1, H, 1, M, 1)
                    Q = Dic(Ray(n, 1))
                    For Ac = 2 To UBound(Ray, 2)
                        If Not IsEmpty(Ray(n, Ac)) Then
                            Select Case 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 "M": 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 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 "M": 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
Application.ScreenUpdating = False
For Each K In Dic.keys
 If Not K = "" Then
 cc = 1
 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
 '###############
   With Sheets(K)
    .Range("A15").Resize(500, 100).ClearContents
    .Range("b13") = 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 = "Date of Birth:"
    .Range("A15").Value = "Admission Date:"
    .Range("A16").Value = "Discharge Date:"
    .Range("A7:b16").Font.Size = 12
    .Range("A7:b16").Font.Bold = True
    .Range("A13:A16").HorizontalAlignment = xlLeft
    .Range("A7").HorizontalAlignment = xlLeft
 '##########
        For n = 0 To 7 Step 2
            cc = cc + 1
            oMax = Application.Max(oMax, Dic(K)(n + 1))
            For c = 1 To Dic(K)(n + 1)
                .Cells(c + 15, cc) = Dic(K)(n)(c)
            Next c
        Next n
  '############# Alter below as required
   .Columns("A:A").ColumnWidth = 17
   .Columns("B:B").ColumnWidth = 14
   .Columns("C:C").ColumnWidth = 14
   .Columns("D:D").ColumnWidth = 14
   .Columns("E:E").ColumnWidth = 14
   .Columns("F:F").ColumnWidth = 14
   .Range("A15").Resize(oMax + 15, 6).HorizontalAlignment = xlCenter
 '###################
  Call ****(Sheets(K))
  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
For Each Pic In sht.Pictures
    Fd = True
Next Pic
If Not Fd Then
    Application.ScreenUpdating = False
    'Change path of your image to suit
    Set Pic = sht.Pictures.Insert("C:\Users\Inigo Montoya\Desktop\Capture44.JPG")
    With sht.Range("A1")
        Picture.Top = .Top
        Picture.Left = .Left
        Picture.LockAspectRatio = msoTrue
        Picture.Height = 450
            End With
    Application.ScreenUpdating = True
Else
    Exit Sub
End If
End Sub
Thanks!
 
Last edited:
Upvote 0
Good morning...

Thank you!

Looks good! Just a couple of things...

The first time I ran the code the macro box came up and I had to select stuudate for it to run.
Mean anything?

The 6 absence type headers and dates are not showing up on the reports.
A19:F19

Were there any changes to Module 1?

What happens if a kid or kids has a lot of absences and the additional dates have to go on a 2nd page?
Would the report automatically add a formatted 2nd page?
I think this will happen once in a while.
Maybe we can put page numbers in the footers just in case?
 
Upvote 0
Not sure about the "macro Box" if its working its OK !!

Absent Date Headers :-
Place the "cc" variable as shown (My error)
Code: 
For Each K In Dic.keys
[B][COLOR=#ff0000] cc = 0[/COLOR][/B]
 If Not K = "" Then
  On Error Resume Next

Module1 was only there for me to place random Leave Initials in each sheet.
You can remove it , as you like !!!

The numbering of footers is something you will need to do (if Required) when you set your Page Layout.
I'm not very clued up about printing lots of pages.
I did notice that column "F" was outside the "A4" sheet size, page layout. !!!!
 
Last edited:
Upvote 0
I added the code to Line 56, correct?
Any other places?
I made the change and ran the code.

Nothing is updating. I have deleted all the report tabs several times and added letters and updated to test it.

A few clarification questions:

Should I be able to hit 'update' on any month tab and have it update all months?
Or, does it only update that specific month?

I should be able to add letters to the tables and have the dates show on reports after hitting 'update', as often as I like, right?

I should only have to delete report tabs when a student leaves, right?

I also should be able to delete a letter, for example...if entered by error, hit update and have the date be removed from the report up hitting 'update'?
Correct?



Here is what I have in there...


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


Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each sht In Worksheets
    If InStr(sht.Name, "_") > 0 Then
         Ray = sht.UsedRange
          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 M(1 To 1500): M(1) = "Late In Early out"
                    Dic.Add Ray(n, 1), Array(S, 1, E, 1, L, 1, V, 1, H, 1, M, 1)
                    Q = Dic(Ray(n, 1))
                    For Ac = 2 To UBound(Ray, 2)
                        If Not IsEmpty(Ray(n, Ac)) Then
                            Select Case 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 "M": 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 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 "M": 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
Application.ScreenUpdating = False
[COLOR=#ff0000][B]For Each K In Dic.keys[/B][/COLOR]
[COLOR=#ff0000][B] cc = 0[/B][/COLOR]
[COLOR=#ff0000][B] If Not K = "" Then[/B][/COLOR]
[COLOR=#ff0000][B]  On Error Resume Next[/B][/COLOR]
    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
 '###############
   With Sheets(K)
    .Range("A15").Resize(500, 100).ClearContents
    .Range("b13") = 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 = "Date of Birth:"
    .Range("A15").Value = "Admission Date:"
    .Range("A16").Value = "Discharge Date:"
    .Range("A7:b16").Font.Size = 12
    .Range("A7:b16").Font.Bold = True
    .Range("A13:A16").HorizontalAlignment = xlLeft
    .Range("A7").HorizontalAlignment = xlLeft
 '##########
        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)
                .Cells(c + 18, cc) = Dic(K)(n)(c) 'NB:- Start Od Dates shown Here as C+18
            Next c
        Next n
  '############# Alter below as required
   .Columns("A:A").ColumnWidth = 17
   .Columns("B:B").ColumnWidth = 14
   .Columns("C:C").ColumnWidth = 14
   .Columns("D:D").ColumnWidth = 14
   .Columns("E:E").ColumnWidth = 14
   .Columns("F:F").ColumnWidth = 14
   .Range("A19").Resize(oMax + 18, 6).HorizontalAlignment = xlCenter
 '###################
  Call ****(Sheets(K))
  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
For Each Pic In sht.Pictures
    Fd = True
Next Pic
If Not Fd Then
    Application.ScreenUpdating = False
    'Change path of your image to suit
    'My path:-
   ' Set Pic = sht.Pictures.Insert("C:\Users\USER1\Desktop\thP2Y8R8D3.jpg")


    Set Pic = sht.Pictures.Insert("C:\Users\Inigo Montoya\Desktop\Capture44.JPG")
    With sht.Range("A1")
        Pic.Top = .Top ' NB The Object is "Pic" not Picture !!
        Pic.Left = .Left
        Pic.LockAspectRatio = msoTrue ' I found when this was Locked I could not change the Picture size !!!
        'Pic.Height = 80
    End With
    Application.ScreenUpdating = True
Else
    Exit Sub
End If
End Sub
 
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,098
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