VBA for Adding Unique Values in Row to Column

[BraytonM]

I am looking for a VBA to do the following: In Sheet1, you will see that Column A is pre-filled and Column C counts all unique values in range: S:AM per row. Additionally, I have a macro that adds X blank rows (determined by column C value) above non-blank row. I would like a macro that adds the Job # in Column D and CP or U to Column E. For instance, look at row 4. AAPPLES worked three jobs but only 2 unique jobs (Job1 CP and Job2 U). I would like a macro that would put "Job1" in D2 and "CP" in E2 and "Job2" in D3 and "U" in E3 and so on for each row that only has values in Column A.

Hopefully, y'all can help! Thank you!

 

[richh]

Hi Brayton,

Not sure if this is exactly what you're looking for, but it's a step in the right direction. I think you might just want job1/job2 to be displayed only once per employee work rate; if so, the code will need a little tailoring to fit your needs. You'll just need to rework the nested IF statement a bit.

Option Explicit

Sub JobRateUpdate()
    Dim ws          As Worksheet    'Your worksheet
    Dim lRow        As Long         'Worksheet's last row
    Dim startRng    As Long         'The 1st emp. row @ currRate
    Dim endRng      As Long         'The last emp. row @ currRate
    Dim currCol     As Integer      'Column S, T, or U
    Dim i, j        As Integer      'Loop counters
        
    
    Set ws = Application.ThisWorkbook.Worksheets("JobSheet")
    lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    currCol = 19 'S Column
    
    For i = 2 To lRow
        For j = i To lRow
            If ws.Cells(j, 2) <> "" Then
                endRng = j
                Exit For
            End If
        Next j
        
        For startRng = i To endRng
            If ws.Cells(endRng, currCol) = "" Then 'if S is blank, goto T col
                currCol = currCol + 1
                
                If ws.Cells(endRng, currCol) = "" Then 'if T is blank, goto U col
                    currCol = currCol + 1
                    
                        If ws.Cells(endRng, currCol) = "" Or currCol > 21 Then 'if U is blank, goto S col
                            currCol = 19
                        End If
                End If
            End If
            
            ws.Cells(startRng, 4) = VBA.Left(ws.Cells(endRng, currCol), _
                    VBA.InStr(1, ws.Cells(endRng, currCol), " ") - 1)
            
            ws.Cells(startRng, 5) = VBA.Mid(ws.Cells(endRng, currCol), _
                    VBA.InStr(1, ws.Cells(endRng, currCol), " ") + 1)
                
            If currCol < 21 Then
                currCol = currCol + 1
            End If
        Next startRng
        
        currCol = 19
        
        i = endRng
        
    Next i
    
    Set ws = Nothing
    
End Sub

 

[BraytonM]

Hello @richh, thank you for the quick reply. When I run this program, my Excel goes into "Not Responding" mode. Perhaps, you could help.

 

[richh]

Hmm... Not too sure; have you tried stepping through the code with F8? Watch the variables in you Locals Window and see what's up; it sounds like it turned into an infinite loop, so my guess is that the column selection IF statements written aren't fitting the needs of your data.

 

[BraytonM]

Hmm... Not too sure; have you tried stepping through the code with F8? Watch the variables in you Locals Window and see what's up; it sounds like it turned into an infinite loop, so my guess is that the column selection IF statements written aren't fitting the needs of your data.

I am not quite sure. I stepped through it with F8 and everything was fine. It auto-fills the columns like it should and doesn't crash; but when I 'run' the macro, it auto-fills the columns and then goes into non-responding mode.

 

[richh]

I'm not too sure about why that's happening. Here's a quick update, which will display variable values per loop; If you start seeing crazy numbers, or the values don't make sense with the data on your worksheet, you can see where that error occurred. It also has a message that is displayed once all the loops have ended to make sure the prog makes it through to the end.

Option Explicit

Sub JobRateUpdate()
    Dim ws          As Worksheet    'Your worksheet
    Dim lRow        As Long         'Worksheet's last row
    Dim startRng    As Long         'The 1st emp. row @ currRate
    Dim endRng      As Long         'The last emp. row @ currRate
    Dim currCol     As Integer      'Column S, T, or U
    Dim i, j        As Integer      'Loop counters
    
    Set ws = Application.ThisWorkbook.Worksheets("JobSheet")
    lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    currCol = 19 'S Column
    
    For i = 2 To lRow
        For j = i To lRow 'Find the last row that houses the job data
            If ws.Cells(j, 2) <> "" Then
                endRng = j
                Exit For
            End If
        Next j
        
        
        
        For startRng = i To endRng 'Loop through emp rate's range and copy data
            If ws.Cells(endRng, currCol) = "" Then 'if S is blank, goto T col
                currCol = currCol + 1
                
                If ws.Cells(endRng, currCol) = "" Then 'if T is blank, goto U col
                    currCol = currCol + 1
                        
                        If ws.Cells(endRng, currCol) = "" Then 'if U is blank, goto S col
                            currCol = 19
                        End If
                End If
            End If
            
            MsgBox "i: " & i & " | lRow: " & lRow & " | Emp No: " & ws.Cells(i, 1) & _
                vbNewLine & vbNewLine & _
                "startRng: " & startRng & " | endRng: " & endRng & _
                vbNewLine & vbNewLine & _
                "currCol: " & currCol
                
            
            ws.Cells(startRng, 4) = VBA.Left(ws.Cells(endRng, currCol), _
                    VBA.InStr(1, ws.Cells(endRng, currCol), " ") - 1)
            
            ws.Cells(startRng, 5) = VBA.Mid(ws.Cells(endRng, currCol), _
                    VBA.InStr(1, ws.Cells(endRng, currCol), " ") + 1)
                
            If currCol < 21 Then
                currCol = currCol + 1
            End If
        Next startRng
        
        currCol = 19 'Reset back to S col
        i = endRng 'Advance counter to the end of the current emp rate's rng
    Next i
    
    MsgBox "Out of the loop"
    
    Set ws = Nothing
    
End Sub

 

[BraytonM]

@richh Thank you for all your help! I am going to figure/manipulate the VBA tomorrow and I will keep you posted.

 

[BraytonM]

@richh I have made another thread that will better describe my situation. I no longer need the Job # and CP/U separated. The new thread link is: VBA for Adding Unique Values in Row to Column D