VBA to loop on Ranges

casper_01

New Member
Joined
May 20, 2020
Messages
10
Office Version
  1. 2016
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
ABCDEFGHIJKLMNOPQRS
1
2Day 1Day 2
3
4Team1Team1
5NameStartEndBreak1Break2Break3NameStartEndBreak1Break2Break3
6Name107:0015:30Name107:0015:30
7Name207:0015:30Name207:0015:30
8Name307:0015:30Name307:0015:30
9Name409:0017:30Name409:0017:30
10Name509:0017:30Name509:0017:30
11Name609:0017:30Name609:0017:30
12Name709:0017:30Name711:3020:00
13Name811:3020:00Name811:3020:00
14Name911:3020:00Name913:3022:00
15Name1013:3022:00Name1013:3022:00
16Name1113:3022:00Name1115:3000:00
17Name1213:3022:00
18Name1313:3022:00
19Name1413:3022:00
20Name1515:3000:00
21Name1615:3000:00
22
23
24
25Team2Team2
26NameStartEndBreak1Break2Break3NameStartEndBreak1Break2Break3
27Name107:0015:30Name107:0015:30
28Name207:0015:30Name209:0017:30
29Name309:0017:30Name311:3020:00
30Name409:0017:30Name413:3022:00
31Name511:3020:00Name513:3022:00
32Name611:3020:00Name615:3000:00
33Name713:3022:00
34Name813:3022:00
35Name915:3000: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
ABCDE
1StartEndBreak1Break2Break3
207:0015:3009:0011:0013:00
307:0015:3009:2011:1513:10
407:0015:3009:4011:3013:20
507:0015:3010:0011:4513:30
607:0015:3010:2012:0013:40
709:0017:3011:0013:0015:00
809:0017:3011:2013:1515:10
909:0017:3011:4013:3015:20
1009:0017:3012:0013:4515:30
1109:0017:3012:2014:0015:40
1209:0017:3012:4014:1515:50
1311:3020:0013:3015:3017:30
1411:3020:0013:5015:4517:40
1511:3020:0014:1016:0017:50
1611:3020:0014:3016:1518:00
1711:3020:0014:5016:3018:10
1813:3022:0015:3017:3019:30
1913:3022:0015:5017:4519:40
2013:3022:0016:1018:0019:50
2113:3022:0016:3018:1520:00
2213:3022:0016:5018:3020:10
2313:3022:0017:1018:4520:20
2415:3000:0017:3019:3021:30
2515:3000:0017:5019:4521:40
2615:3000:0018:1020:0021:50
2715:3000:0018:3020:1522:00
2815:3000:0018:5020:3022:10
Breaks


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

VBA Code:
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,
 
Last edited by a moderator:

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,468
Office Version
  1. 365
Platform
  1. Windows
Are the break times always staggered by 20min for break 1 15 for break 2 & 10 for break 3?
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.

casper_01

New Member
Joined
May 20, 2020
Messages
10
Office Version
  1. 2016
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,468
Office Version
  1. 365
Platform
  1. Windows
ok, how about
VBA Code:
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

New Member
Joined
May 20, 2020
Messages
10
Office Version
  1. 2016
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,468
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,404
Messages
5,636,083
Members
416,897
Latest member
YAFI

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
Top