VBA Help (Again)

[markster]

Hello

I just need some macro code to reconfigure reference numbers so I can sort in a pivot table. I have uploaded an image whereby you will see that the reference number in the current format is in COLUMN K from Row 7 downwards. I need it to reconfigure and populate the new format in COLUMN S from Row 7 downwards. If the reference number begins with CL I need it to extracts G number the S number and the J number and add the CL number to the end of the reference number (as shown in the image). If the number begins with TH it just extracts the numbers G number the S number and the J number. I think it probably sounds more complicated than it is but if you look at the image I think it is pretty straightforward for someone who knows how to code VBA.

Thanks in advance for any help.
Mark

 

[mumps]

Try:

Sub ExtractNumbers()
    Application.ScreenUpdating = False
    Dim rng As Range, vRng As Variant
    For Each rng In Range("K7", Range("K" & Rows.Count).End(xlUp))
        vRng = Split(rng, "_")
        If Left(vRng(0), 2) = "CL" Then
            Range("S" & rng.Row) = Mid(vRng(1), 2, 999) & "_" & Mid(vRng(2), 2, 999) & "_" & Mid(vRng(3), 2, 999) & "_" & Split(vRng(0), ".")(0)
        ElseIf Left(vRng(0), 2) = "TH" Then
            Range("S" & rng.Row) = Mid(vRng(1), 2, 999) & "_" & Mid(vRng(2), 2, 999) & "_" & "_" & Mid(vRng(3), 2, 999)
        End If
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[igold]

How about this:

Sub ChangeString()
    Dim str As String, lst As String, i As Long
    Dim spl1
    For i = 7 To Cells(Rows.Count, "K").End(xlUp).Row
        str = Range("K" & i)
        spl1 = Split(str, "_")
        If Left(spl1(0), 1) = "C" Then
            lst = Mid(spl1(1), 2) & "_" & Mid(spl1(2), 2) & "_" & Mid(spl1(3), 2) & "_" & Left(spl1(0), 3)
        End If
        If Left(spl1(0), 1) = "T" Then
            lst = Mid(spl1(1), 2) & "_" & Mid(spl1(2), 2) & "_" & Mid(spl1(3), 2)
        End If
        Range("S" & i) = lst
    Next
End Sub

 

[markster]

Thanks guys will give them a try tomorrow morning and will let you know. Have a great evening.

Thanks again.
Mark

 

[igold]

@mumps - Just as a friendly FYI, you have a two underscores here:

ElseIf Left(vRng(0), 2) = "TH" Then
    Range("S" & rng.Row) = Mid(vRng(1), 2, 999) & "_" & Mid(vRng(2), 2, 999) & "_" & "_" & Mid(vRng(3), 2, 999)
End If

?

igold

 

[mumps]

@igold
Thanks for picking up on that. There should only be one underscore.

Range("S" & rng.Row) = Mid(vRng(1), 2, 999) & "_" & Mid(vRng(2), 2, 999)  & "_" & Mid(vRng(3), 2, 999)

 

[markster]

Both work a treat - thanks very much guys.
Mark

 

[igold]

Both @mumps and my code are going to run essentially at about the same speed. If you had a substantial amount of data this code would run much much quicker than what we initially posted.

Sub ChangeString()
    Dim spl1, arr, arrs, i As Long
    arr = Range("K7:K" & Cells(Rows.Count, "K").End(xlUp).Row)
    ReDim arrs(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        Select Case Left(arr(i, 1), 1)
            Case Is = "C"
                spl1 = Split(arr(i, 1), "_")
                arrs(i, 1) = Mid(spl1(1), 2) & "_" & Mid(spl1(2), 2) & "_" & Mid(spl1(3), 2) & "_" & Left(spl1(0), 3)
            Case Is = "T"
                spl1 = Split(arr(i, 1), "_")
                arrs(i, 1) = Mid(spl1(1), 2) & "_" & Mid(spl1(2), 2) & "_" & Mid(spl1(3), 2) & "_" & Left(spl1(0), 3)
        End Select
    Next
    Range("S7").Resize(UBound(arrs)) = arrs
End Sub