VBA to loop on Ranges

[casper_01]

VBA to loop on Ranges



Hello,

I am conducting a project in which I need to create simultaneously several timesheets in a single excel sheet “Planner”, as shown below:

Book1- Test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1
2		Day 1									Day 2
3
4		Team1									Team1
5		Name	Start	End	Break1	Break2	Break3				Name	Start	End	Break1	Break2	Break3
6		Name1	07:00	15:30							Name1	07:00	15:30
7		Name2	07:00	15:30							Name2	07:00	15:30
8		Name3	07:00	15:30							Name3	07:00	15:30
9		Name4	09:00	17:30							Name4	09:00	17:30
10		Name5	09:00	17:30							Name5	09:00	17:30
11		Name6	09:00	17:30							Name6	09:00	17:30
12		Name7	09:00	17:30							Name7	11:30	20:00
13		Name8	11:30	20:00							Name8	11:30	20:00
14		Name9	11:30	20:00							Name9	13:30	22:00
15		Name10	13:30	22:00							Name10	13:30	22:00
16		Name11	13:30	22:00							Name11	15:30	00:00
17		Name12	13:30	22:00
18		Name13	13:30	22:00
19		Name14	13:30	22:00
20		Name15	15:30	00:00
21		Name16	15:30	00:00
22
23
24
25		Team2									Team2
26		Name	Start	End	Break1	Break2	Break3				Name	Start	End	Break1	Break2	Break3
27		Name1	07:00	15:30							Name1	07:00	15:30
28		Name2	07:00	15:30							Name2	09:00	17:30
29		Name3	09:00	17:30							Name3	11:30	20:00
30		Name4	09:00	17:30							Name4	13:30	22:00
31		Name5	11:30	20:00							Name5	13:30	22:00
32		Name6	11:30	20:00							Name6	15:30	00:00
33		Name7	13:30	22:00
34		Name8	13:30	22:00
35		Name9	15:30	00:00
36
37
38
39
40
41
42
43
Planner

The timesheets needs to be completed based on the information available in “Breaks“ sheet:

Book1- Test.xlsm
	A	B	C	D	E
1	Start	End	Break1	Break2	Break3
2	07:00	15:30	09:00	11:00	13:00
3	07:00	15:30	09:20	11:15	13:10
4	07:00	15:30	09:40	11:30	13:20
5	07:00	15:30	10:00	11:45	13:30
6	07:00	15:30	10:20	12:00	13:40
7	09:00	17:30	11:00	13:00	15:00
8	09:00	17:30	11:20	13:15	15:10
9	09:00	17:30	11:40	13:30	15:20
10	09:00	17:30	12:00	13:45	15:30
11	09:00	17:30	12:20	14:00	15:40
12	09:00	17:30	12:40	14:15	15:50
13	11:30	20:00	13:30	15:30	17:30
14	11:30	20:00	13:50	15:45	17:40
15	11:30	20:00	14:10	16:00	17:50
16	11:30	20:00	14:30	16:15	18:00
17	11:30	20:00	14:50	16:30	18:10
18	13:30	22:00	15:30	17:30	19:30
19	13:30	22:00	15:50	17:45	19:40
20	13:30	22:00	16:10	18:00	19:50
21	13:30	22:00	16:30	18:15	20:00
22	13:30	22:00	16:50	18:30	20:10
23	13:30	22:00	17:10	18:45	20:20
24	15:30	00:00	17:30	19:30	21:30
25	15:30	00:00	17:50	19:45	21:40
26	15:30	00:00	18:10	20:00	21:50
27	15:30	00:00	18:30	20:15	22:00
28	15:30	00:00	18:50	20:30	22:10
Breaks

I used the following code to add the breaks in one timesheet:

Sub Breaks ()

    Dim z, i As Long, ii As Long, txt As String, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    z = Sheets("Breaks").Cells(1).CurrentRegion.Value
    For i = 2 To UBound(z, 1)
        txt = Join(Array(z(i, 1), z(i, 2)), Chr(2))
        If Not dic.exists(txt) Then
            Set dic(txt) = CreateObject("System.Collections.ArrayList")
        End If
        ReDim w(1 To UBound(z, 2) - 2)
        For ii = 3 To UBound(z, 2)
            w(ii - 2) = z(i, ii)
        Next
        dic(txt).Add w
    Next
    With Sheets("Planner").Cells(1).CurrentRegion
        .Offset(1, 4).ClearContents
        z = .Value
        For i = 2 To UBound(z, 1)
            txt = Join(Array(z(i, 3), z(i, 4)), Chr(2))
            If dic.exists(txt) Then
                If dic(txt).Count Then
                    For ii = 4 To UBound(z, 3)
                        z(i, ii) = dic(txt)(0)(ii - 3)
                    Next
                    dic(txt).RemoveAt 0
                End If
            End If
        Next
        .Value = z
    End With
Dim BlankFound As Boolean
Dim x As Long
End Sub

Currently I am looking to implement a code with Loop function with which I can simultaneously fill in all the timesheets. Any suggestions?

Thank you,

 

[Fluff]

Are the break times always staggered by 20min for break 1 15 for break 2 & 10 for break 3?

 

[casper_01]

In cases where the start/end time are the same for different names, the breaks vary in each start/end time by 20/15/10. The first break in each different start/end time is 2 hours after start time, second break is 4 hours after start time and third break 6 hours after. For the following breaks with the same start/end the breaks are updated as you described.

 

[Fluff]

ok, how about

Sub casper()
   Dim Dary As Variant, Ary As Variant
   Dim Dic As Object
   Dim Txt As String
   Dim r As Long, i As Long, j As Long
   
   Ary = Array("C5", "K5", "C26", "K26")
   Dary = Sheets("Breaks").Range("A1").CurrentRegion.Value2
   Set Dic = CreateObject("scripting.dictionary")
   For r = 2 To UBound(Dary)
      Txt = Dary(r, 1) & "|" & Dary(r, 2)
      If Not Dic.Exists(Txt) Then Dic.Add Txt, Array(Dary(r, 3), Dary(r, 4), Dary(r, 5))
   Next r
   With Sheets("Planner")
      For i = 0 To UBound(Ary)
         Dary = .Range(Ary(i)).CurrentRegion.Value2
         For r = 3 To UBound(Dary)
            Txt = Dary(r, 2) & "|" & Dary(r, 3)
            If Dary(r, 2) = Dary(r - 1, 2) Then j = j + 1 Else j = 0
            Dary(r, 4) = Dic(Txt)(0) + j * 0.0138889
            Dary(r, 5) = Dic(Txt)(1) + j * 0.0104167
            Dary(r, 6) = Dic(Txt)(2) + j * 0.0069444
         Next r
         .Range(Ary(i)).CurrentRegion.Value = Dary
      Next i
   End With
End Sub

 

[casper_01]

I have tested this one and it worked perfectly well even when I added more team and days. Thanks a lot for your help on this one Fluff. I hope I can also be of a help for other moving forward. Excel is amazing!

 

[Fluff]

You're welcome & thanks for the feedback.