VBA for Adding Unique Values in Row to Column

BraytonM

New Member
Joined
Jul 25, 2021
Messages
24
Office Version
  1. 365
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!
 

Attachments

  • Excel Help.PNG
    Excel Help.PNG
    47.2 KB · Views: 8

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

richh

Board Regular
Joined
Jun 24, 2007
Messages
243
Office Version
  1. 365
  2. 2016
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.

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

JobRateCopyPasta.gif
 

BraytonM

New Member
Joined
Jul 25, 2021
Messages
24
Office Version
  1. 365
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

Board Regular
Joined
Jun 24, 2007
Messages
243
Office Version
  1. 365
  2. 2016
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

New Member
Joined
Jul 25, 2021
Messages
24
Office Version
  1. 365

ADVERTISEMENT

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

Board Regular
Joined
Jun 24, 2007
Messages
243
Office Version
  1. 365
  2. 2016
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.

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

New Member
Joined
Jul 25, 2021
Messages
24
Office Version
  1. 365
@richh Thank you for all your help! I am going to figure/manipulate the VBA tomorrow and I will keep you posted.
 

Forum statistics

Threads
1,141,707
Messages
5,707,988
Members
421,539
Latest member
zuniBM

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