VBA Code to extract and combine alphanumeric values

[jerryg72]

Can I get the vba code for the below formula please?
=IF(A2,UPPER(LEFT(D2,3)&LEFT(C2,3)&TEXT(ROWS(A$2:A2),"0000")),"")

I need to take first three digits/numbers from column D2 & C2 and add number starting from 0001 as it goes down each row it should increase as 0001, 0002, 0003... so forth. Eg. B113X40001, B114X60002 (The first six digit vary depending on what the D2 & C2 column has in it).

Thanks

 

[JackDanIce]

What cell/column is the output going to?
You may need to adjust below (so make copy of your file first) which outputs to E2, but try running:

Sub PartyTime()

    Dim x As Long: x = Cells(Rows.Count, 3).End(xlUp).Row
    Dim arr() As Variant: arr = Cells(2, 3).Resize(x - 1, 2).Value
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        arr(x, 1) = Ucase$(Left$(arr(x, 1), 3) & Left$(arr(x, 2), 3) & Format(x, "0000"))
    Next x
    
    With Cells(2, 5).Resize(UBound(arr, 1))
        .Value = Application.Index(arr, , 1)
        .EntireColumn.AutoFit
    End With
    
    Erase arr
End Sub

 

[DanteAmor]

I guess the formula goes in column E or adjusts the column in red letters.

Sub Macro11()
  With Range("[COLOR=#ff0000]E2:E[/COLOR]" & Range("A" & Rows.Count).End(xlUp).Row)
    .Formula = "=IF(A2,UPPER(LEFT(D2,3)&LEFT(C2,3)&TEXT(ROWS(A$2:A2),""0000"")),"""")"
  End With
End Sub

----------------

If you do not want the formulas and keep the values, then it can be:

Sub Macro12()
  With Range("[COLOR=#ff0000]E2:E[/COLOR]" & Range("A" & Rows.Count).End(xlUp).Row)
    .Formula = "=IF(A2,UPPER(LEFT(D2,3)&LEFT(C2,3)&TEXT(ROWS(A$2:A2),""0000"")),"""")"
[COLOR=#0000ff]    .Value = .Value[/COLOR]
  End With
End Sub

 

[jerryg72]

Thank you so much. It did work fine on the first row but not in newly added rows.

 

[jerryg72]

Thank you so much JackDanICe. It did work fine on the first row but not in newly added rows.

What cell/column is the output going to?
You may need to adjust below (so make copy of your file first) which outputs to E2, but try running:

Sub PartyTime()

    Dim x As Long: x = Cells(Rows.Count, 3).End(xlUp).Row
    Dim arr() As Variant: arr = Cells(2, 3).Resize(x - 1, 2).Value
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        arr(x, 1) = Ucase$(Left$(arr(x, 1), 3) & Left$(arr(x, 2), 3) & Format(x, "0000"))
    Next x
    
    With Cells(2, 5).Resize(UBound(arr, 1))
        .Value = Application.Index(arr, , 1)
        .EntireColumn.AutoFit
    End With
    
    Erase arr
End Sub

 

[JackDanIce]

Given you've had the same outcome from both suggested pieces of (different) code, I suspect there is something on your set up/spreadsheet you've not detailed to anyone who can't see your screen...

 

[DanteAmor]

Thank you so much. It did work fine on the first row but not in newly added rows.

It is a macro that you must execute every time.
If you add new rows then you must run the macro.

It is exactly with your formula, you have to copy the formula in the new rows.
If you require it in automatic then, you must comment on your original request.

Put the following code in the events of your sheet

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A:A, C:C, D:D")) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        With Range("E2:E" & Range("A" & Rows.Count).End(xlUp).Row)
          .FormulaR1C1 = "=IF(RC[-4],UPPER(LEFT(RC[-1],3)&LEFT(RC[-2],3)&TEXT(ROWS(R2C[-4]:RC[-4]),""0000"")),"""")"
        End With
    End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.