Macro extracting part of string

[peter_sjogarde]

I am trying to figure out how to keep only a part of a string. The part I want to keep is marked with capitals in the example below.

Example of cell contents:
[something between brackets, like this]something else, belonging to the, same occurrence, PART OF INTEREST;[a new occurrence]with, a string, like this, AND STRING OF INTEREST

So from this cell I want to keep or print in new column "PART OF INTEREST;AND STRING OF INTEREST"

I.e. the part between the last comma and the semicolon for each occurrence and the part after the last comma of the whole string


I do not want a function but rather a macro doing this and puts the result in a new column. I use this code to loop and remove the brackets:

   Dim x As Integer
   ' Set numrows = number of rows of data.
   NumRows = Range("A2", Range("A2").End(xlDown)).Rows.Count

   ActiveCell.Select

   For x = 1 To NumRows
      ActiveCell.Offset(1, 0).Select
      Selection.replace What:="
[*]", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
   Next

 

[Jon von der Heyden]

Hi Peter

Assuming that there will always be the same # of elements:

Public Sub GetElements()
    Dim lngLastRow
    Dim rngCell As Range
    Dim varTempArray As Variant
    
    With ActiveSheet
        lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For Each rngCell In .Range("A2:A" & lngLastRow)
            varTempArray = Split(Replace$(rngCell.Value, ";", ","), ",")
            With Application
                rngCell.Offset(, 1).Value = Join$(.Index(.Transpose(varTempArray), VBA.Array(5, 9), 1), ";")
            End With
        Next rngCell
    End With
End Sub

 

[MickG]

Try:-

[COLOR="Navy"]Sub[/COLOR] MG04Apr08
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] oWds
[COLOR="Navy"]Dim[/COLOR] W
[COLOR="Navy"]Dim[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        oWds = Split(Dn, ",")
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] W [COLOR="Navy"]In[/COLOR] oWds
        [COLOR="Navy"]If[/COLOR] InStr(W, ";") > 0 [COLOR="Navy"]Then[/COLOR] Temp = Left(W, InStr(W, ";"))
    [COLOR="Navy"]Next[/COLOR] W
        Dn.Offset(, 1) = Temp & oWds(UBound(oWds))
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[peter_sjogarde]

Thank you Jon! Unfortunately the number of elements vary from 0 to hundreds, so I suppose that your code will not work on my data.

 

[Jon von der Heyden]

If it is literally upper-case you are after:

Public Sub CapsOnly()
    Dim objRX As Object: Set objRX = CreateObject("vbscript.regexp")
    Dim lngLastRow As Long
    Dim rngTable As Range, rngCell As Range

    With ActiveSheet
        lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rngTable = .Range("A2:A" & lngLastRow)
    End With
    
    With objRX
        .Pattern = "([^A-Z ;])"
        .IgnoreCase = False
        .Global = True
        For Each rngCell In rngTable
            If .Test(rngCell.Value) Then
                rngCell.Offset(, 1).Value = WorksheetFunction.Trim(.Replace(rngCell, ""))
            End If
        Next rngCell
    End With
End Sub

 

[peter_sjogarde]

Thanks but it is not literally upper case that i am after.

 

[peter_sjogarde]

Thank you Mick. It seems to work but it stop when it came to a blank row. Do you have a solution for that. I guess some if condition but I am not very good at this yet so I could not get it to work.

 

[pgc01]

Hi Peter

Try this test. Write some values in A1:A1 and the result will be in the cells to the right:

Sub Test()
Dim r As Range, rC As Range
 
Set r = Range("A1:A5")
With CreateObject("VBScript.RegExp")
    .Pattern = "[^;]+?,([^;,]+(;|$))"
    .Global = True
    For Each rC In r
        If .Test(rC) Then rC.Offset(, 1) = .Replace(rC, "$1")
    Next rC
End With
End Sub

 

[Jon von der Heyden]

Hi Peter

Try this test. Write some values in A1:A1 and the result will be in the cells to the right:

Sub Test()
Dim r As Range, rC As Range
 
Set r = Range("A1:A5")
With CreateObject("VBScript.RegExp")
    .Pattern = "[^;]+?,([^;,]+(;|$))"
    .Global = True
    For Each rC In r
        If .Test(rC) Then rC.Offset(, 1) = .Replace(rC, "$1")
    Next rC
End With
End Sub

Works for me!

$1? That's new to me! Can you explain or refer me to an explanation?

Edit: Got it!

 

[peter_sjogarde]

Thank you pgc01! It works!