Good Evening all the experts out there. Need help in VBA Excel macro in for each - for next looping

[Rahul Soni]

I am working on a free school project and trying to build an automated system for assigning substitue teachers. I have done alsmot everything but need help in For Each - for next loop to plug in teachers if someone is absent on a given day. The code I wrote so far is looping but not assigning the values one by one. I know something smaller is missing hence need your kind help.

What I need is that : for each red highlighted cell on Time Table sheet - below the highlighted cell a teacher name should be populated from Info sheet column f and it should continue till all the red highlighted cells have been populated with the unique names from Info sheet column F.

Sub setasignee()

Dim rSH As Worksheet

Dim sSH As Worksheet



Set rSH = ThisWorkbook.Sheets("Time Table")
Set sSH = ThisWorkbook.Sheets("Info")

Set Rng = rSH.Range("D5:AU64")


'a = sSH.Range("F" & Rows.Count).End(xlUp).Row



'Dim fName As String








For a = 2 To sSH.Range("F" & Rows.Count).End(xlUp).Row

fName = sSH.Range("F" & a).Value

For Each c In Rng

If c.Interior.ColorIndex = 3 And c.Value <> "" Then



c.Offset(1, 0).Value = fName

'If c.Offset(1, 0).Value <> "" Then Exit For






End If


Next c


Next a



'Next a





End Sub

 

[Alex Blakenburg]

Welcome to the Forum.
If you could click on the VBA button and post your code inside the tags that would be helpful since it keeps the formatting and makes it easier to read.

As I see it you have a selection of cells that need populating and a list of names to populate those cells.
What is missing is some sort of logic to choose which names to use for which empty cells.

As it stands with the if statement commented out, the line below will run for each empty cell for each name. That means it will keep overwriting the value in the empty cells so that only the last name will appear.

c.Offset(1, 0).Value = fName

If you include the If statement it will only populate the empty cells on the first pass so only the first name will appear.

            c.Offset(1, 0).Value = fName
            If c.Offset(1, 0).Value <> "" Then Exit For

What is the logic for allocating names ? Does each name get allocated the next free timeslot until everyone has 1 time assigned and then loop through a 2nd time etc until no empty cells remain ?

 

[Alex Blakenburg]

Below is a version that allocates the available time evenly in order of the names in the list.
We would normally use an array to do it but you might find this easier,

Sub setasignee()

Dim rSH As Worksheet
Dim sSH As Worksheet
Dim Rng As Range, rngName As Range, c As Range
Dim fName As String, iName As Long, cntName As Long

Set rSH = ThisWorkbook.Sheets("Time Table")
Set sSH = ThisWorkbook.Sheets("Info")

'Set Rng = rSH.Range("D5:AU64")
Set Rng = rSH.Range("D5:Q20")
Set rngName = sSH.Range("F2:F" & sSH.Range("F" & Rows.Count).End(xlUp).Row)
cntName = rngName.Cells.Count
iName = 0

    For Each c In Rng
        If c.Interior.ColorIndex = 3 And c.Value <> "" Then
            ' if last name used loop back to the top of the list
            If iName = cntName Then
                iName = 1
            Else
                iName = iName + 1
            End If
          
            fName = rngName.Cells(iName).Value
            c.Offset(1, 0).Value = fName
        End If
      
    Next c
End Sub

 

[Rahul Soni]

Welcome to the Forum.
If you could click on the VBA button and post your code inside the tags that would be helpful since it keeps the formatting and makes it easier to read.

As I see it you have a selection of cells that need populating and a list of names to populate those cells.
What is missing is some sort of logic to choose which names to use for which empty cells.

As it stands with the if statement commented out, the line below will run for each empty cell for each name. That means it will keep overwriting the value in the empty cells so that only the last name will appear.

c.Offset(1, 0).Value = fName

If you include the If statement it will only populate the empty cells on the first pass so only the first name will appear.

            c.Offset(1, 0).Value = fName
            If c.Offset(1, 0).Value <> "" Then Exit For

What is the logic for allocating names ? Does each name get allocated the next free timeslot until everyone has 1 time assigned and then loop through a 2nd time etc until no empty cells remain ?

Good Morning Alex and thank you so much for replying. I am attaching a sheet with the vba code. But I will describe my end objective again.


This is just the begning of the bigger logic that I was trying to build. The end objective is that every highlighted
cell on sheet Time Table should get one unique name assigned from Info sheet column F
**IF Classes Each Day (Column G) has less than 4 classes. So before assigning the name logic should check
Column G if it is less than 4 than pick one name from adjacent cell from column F and paste it below the
red highlighted cells on sheet Time Table.

[CODE=vba]Sub setasignee()

    'first one that I wrote originally.
    'this is just the begning of the bigger logic that I was trying to build. The end objective is that every highlighted
    'cell on sheet Time Table should get one unique name assigned from Info sheet column F
    '**IF Classes Each Day (Column G) has less than 4 classes. So before assigning the name logic should check
    'Column G if it is less than 4 than pick one name from adjacent cell from column F and paste it below the
    'red highlighted cells on sheet Time Table.
    
    
    
    
    Dim rSH As Worksheet
    
    Dim sSH As Worksheet
    
   

    Set rSH = ThisWorkbook.Sheets("Time Table")
    Set sSH = ThisWorkbook.Sheets("Info")
    
    Set Rng = rSH.Range("D5:AU64")
    
    
    'a = sSH.Range("F" & Rows.Count).End(xlUp).Row
    
    

    'Dim fName As String
    
    
             
                
                
               
             
                
             For a = 2 To sSH.Range("F" & Rows.Count).End(xlUp).Row
    
                    fName = sSH.Range("F" & a).Value
            
                For Each c In Rng
                                                  
             If c.Interior.ColorIndex = 3 And c.Value <> "" Then
             
             
             
             c.Offset(1, 0).Value = fName
             
             'If c.Offset(1, 0).Value <> "" Then Exit For
             
             
             
             
                         
                    
             End If
             
        
                Next c
                
                
           Next a
                    
                    
                    
        'Next a
        
        
        
        

End Sub



Sub nyawala()

'second one I was trying to write to figure out loop within loop.

        Dim t As Range
        Dim x As Range
        Dim rSH As Worksheet
        Dim sSH As Worksheet
        Dim rng1 As Range
        Dim rng2 As Range
        
    
   

    Set rSH = ThisWorkbook.Sheets("Time Table")
    Set sSH = ThisWorkbook.Sheets("Info")
        
    'Set rng1 = rSH.Range("D5:BU70")
    'Set rng2 = sSH.Range("F" & Rows.Count).End(xlUp).Row
    
    For Each t In rSH.Range("D5:BU70")
    
    For Each x In sSH.Range("F2:F23")
    
    'For Each x In sSH.Range(Cells(2, Cell.Column), Cells(Rows.Count, Cell.Column).End(xlUp))
    
        
        
            If t.Interior.ColorIndex = 3 And t.Value <> "" Then
            
                t.Offset(1, 0).Value = x.Value
                
              
        
        End If
        
            Next x
        
            Next t
            
        
End Sub

[/CODE]

 

[Alex Blakenburg]

I am not sure that I am following if the macro needs to do something with the less that 4 comment.
You have merged cells, that significantly complicates things and is avoided like the plague by most experienced Excel users.

The the code I gave you but out in the range you want which seems to have changed and delete my test range.

Set Rng = rSH.Range("D5:BU70")
Set Rng = rSH.Range("D5:Q20")

I suspect the Merged cells will cause it some grief.
Edit: I did try it with merging some of the cells and seemed to still work.
Come back and tell me what it is and isn't doing and please instal XL2BB and provide an XL2BB of what you have in your picture.

XL2BB
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

 

[Rahul Soni]

I am not sure that I am following if the macro needs to do something with the less that 4 comment.
You have merged cells, that significantly complicates things and is avoided like the plague by most experienced Excel users.

The the code I gave you but out in the range you want which seems to have changed and delete my test range.

Set Rng = rSH.Range("D5:BU70")
Set Rng = rSH.Range("D5:Q20")

I suspect the Merged cells will cause it some grief.
Edit: I did try it with merging some of the cells and seemed to still work.
Come back and tell me what it is and isn't doing and please instal XL2BB and provide an XL2BB of what you have in your picture.

XL2BB
MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Thank you Alex for continuously replying. I agree merge cells are a big problem but I got around them by using a helper table kind of (so at least nothing to worry as of now on that part).

The code you provided does seems to work properly with the merged cells as well, so we are set with that part.
What I mean by <4 is that code should assign the name, **only after checking column G value from Sheet name "Info. So iterate through column G, where cell value is <4 and choose adjacent name from column F, populated the cell below the red highlighted cell on Time Table sheet. Continue looping until all the cells below red highilighted cells on Time Table is filled with the names where column had <4 classes (basically cell value was less than 4).

Since I am starting with the Mr Excel will follow all the rules of posting etc and will familirize myself little more. So far you have been really kind in answering my questions.

Thank you once again for the first piece code. It does solve my half of the problem already.

 

[Alex Blakenburg]

How does column G get populated ? Does it need to be incremented each time a name is allocated ?
If yes then what resets it the next time or are there formulas in there ?

 

[Rahul Soni]

How does column G get populated ? Does it need to be incremented each time a name is allocated ?
If yes then what resets it the next time or are there formulas in there ?

Yes column f will be populated through a formula and that will be fed by another sheet.
We do not need to increment but we need to check the cell value of column f is equal to <4 or not in every iteration. If the cell value is less than 4 then adjacent cell will be picked up for populating the cell below the red highlighted cell on time table from column g.

For example
Column G Column F
Name1 3
Name2. 5
Name 6. 2

Then first red cell below will have name1 and subsequent will have name6. Because both of these have column f value <4.

 

[Alex Blakenburg]

This is a bit ugly but see if this works for you.

Sub setasignee_v02()

Dim rSH As Worksheet
Dim sSH As Worksheet
Dim Rng As Range, rngName As Range, c As Range
Dim fName As String, iName As Long, cntName As Long, icurrName As Long

Set rSH = ThisWorkbook.Sheets("Time Table")
Set sSH = ThisWorkbook.Sheets("Info")

Set Rng = rSH.Range("D5:BU70")
Set rngName = sSH.Range("F2:G" & sSH.Range("F" & Rows.Count).End(xlUp).Row)
cntName = rngName.Columns(1).Cells.Count
iName = 0

    For Each c In Rng
        If c.Interior.ColorIndex = 3 And c.Value <> "" Then
                icurrName = iName
            iName = iName + 1
            If iName > cntName Then iName = 1               ' if last name then loop back to the top of the list
            
            Do While rngName.Cells(iName, 2).Value >= 4 And icurrName <> iName
                If iName = cntName Then
                    iName = 1                               ' if last name then loop back to the top of the list
                Else
                    iName = iName + 1
                End If
            Loop
            If icurrName = iName And rngName.Cells(iName, 2).Value >= 4 Then Exit For
            
            fName = rngName.Cells(iName, 1).Value
            c.Offset(1, 0).Value = fName
        End If
    Next c
End Sub

 

[Rahul Soni]

This is a bit ugly but see if this works for you.

Sub setasignee_v02()

Dim rSH As Worksheet
Dim sSH As Worksheet
Dim Rng As Range, rngName As Range, c As Range
Dim fName As String, iName As Long, cntName As Long, icurrName As Long

Set rSH = ThisWorkbook.Sheets("Time Table")
Set sSH = ThisWorkbook.Sheets("Info")

Set Rng = rSH.Range("D5:BU70")
Set rngName = sSH.Range("F2:G" & sSH.Range("F" & Rows.Count).End(xlUp).Row)
cntName = rngName.Columns(1).Cells.Count
iName = 0

    For Each c In Rng
        If c.Interior.ColorIndex = 3 And c.Value <> "" Then
                icurrName = iName
            iName = iName + 1
            If iName > cntName Then iName = 1               ' if last name then loop back to the top of the list
           
            Do While rngName.Cells(iName, 2).Value >= 4 And icurrName <> iName
                If iName = cntName Then
                    iName = 1                               ' if last name then loop back to the top of the list
                Else
                    iName = iName + 1
                End If
            Loop
            If icurrName = iName And rngName.Cells(iName, 2).Value >= 4 Then Exit For
           
            fName = rngName.Cells(iName, 1).Value
            c.Offset(1, 0).Value = fName
        End If
    Next c
End Sub

Thank you so much Alex. This gives me the needed hint and path to move on. So grateful. The code seems to be working as expected and I will tweak it further. Once again thank you so much and you have great rest of the day. Anything I can help with ever please feel free to email.