Parsing data in a range of cells with VBA/Macro to replace content

Hi everyone,

I'm looking for a way to parse data in a spreadsheet via as automated a method as possible to save manually wading through cell after cell in multiple workbooks.

The data is imported with several values to a cell and what I would like to do is be able to select a range of cells and then parse them so that only one value per cell is left.

I've figured out via guides online how to use the LEFT and FIND functions to be able to complete part of my parse, but in doing so to another cell rather than replacing the previous data. I've no idea how to take this forwards and turn a simple formula into a VBA solution however.

What I'd like to be able to do is parse the cells and leave the results in each cell, a kind of parse and replace function if you will.

I've attached a simple workbook that shows the source data and also shows beneath the two types of results I'd like to try and achieve.

1. Being able to parse the data to leave only the % values present (in the same cell)
2. Being able to the parse data to leave only the values in the () present (in the same cell)

Could somebody point me in the right direction please. What I'm hoping to be able to do ultimately is tie the macro to a button in the ribbon (Excel 2010 user) so I can select a range of cells, click on the macro and it then runs through each cell and parses by either method 1 or method 2 depending on which results I'd prefer to see. So 2 macros, 2 buttons, one for each I was thinking.

Obviously, if there's a better way (I've been using Excel for years but am new to VBA) please do point me in the right direction.

Many thanks for any assistance you can offer.

Generally worksheet functions are faster so you should stick with them and just use your formula on a different sheet. However since you have asked for a macro to replace your data, see the below, there are two subs and one function:

And can be called like

GetPercentage Sheet1.range("A2:F8")

or

GetNoBrackets Sheet1.range("A2:F8")

Public Sub GetPercentage(rng As Range)
Dim vCells As Variant
Dim x As Long
Dim y As Long

vCells = rng.Value

For x = LBound(vCells) To UBound(vCells)
    For y = LBound(vCells, 2) To UBound(vCells, 2)
        vCells(x, y) = Left(vCells(x, y), InStr(1, vCells(x, y), "%"))
    Next y
Next x

    rng.Value = vCells

End Sub



Public Sub GetNoBrackets(rng As Range)
Dim vCells As Variant
Dim x As Long
Dim y As Long

vCells = rng.Value

For x = LBound(vCells) To UBound(vCells)
    For y = LBound(vCells, 2) To UBound(vCells, 2)
        vCells(x, y) = ExtractBrackets(vCells(x, y))
    Next y
Next x

    rng.Value = vCells

End Sub


Public Function ExtractBrackets(ByVal strIn As String) As String
Dim regEx As Object
Dim regExM As Object


 Set regEx = CreateObject("vbscript.regexp")
    With regEx
        .Pattern = "[(][0-9]*[)]"
        .MultiLine = False
        .Global = False
        .IgnoreCase = True
    End With
     
    Set regExM = regEx.Execute(strIn)
    ExtractBrackets = Mid(regExM(0), 2, Len(regExM(0)) - 2)
    
    
End Function

The faster way with no looping would be to apply the formula to a range then copy the results back over the source data, however I don't know how far your data extends though you could do this on another sheet.

Something like:

Sub Percentages(rng As Range)
Dim rng1 As Range
Set rng1 = Sheet2.Cells(1, 1).Resize(rng.Rows.Count, rng.Columns.Count)
rng1.Formula = "=LEFT(Sheet1!A2,FIND(""%"",Sheet1!A2))"
rng.Value = rng1.Value
rng1.ClearContents
End Sub

or use

Sub snb()
 sn = Cells(1).CurrentRegion
 For j = 0 To UBound(sn) * UBound(sn, 2) - 1
  If InStr(sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1), "(") > 0 Then sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1) = Split(sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1), "(")(0)
 Next
    
 Cells(1).CurrentRegion.Offset(, UBound(sn, 2) + 2) = sn
End Sub

and

Sub snb2()
 sn = Cells(1).CurrentRegion
 For j = 0 To UBound(sn) * UBound(sn, 2) - 1
  If InStr(sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1), "(") > 0 Then sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1) = Split(Split(sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1), "(")(1), ")")(0)
 Next
    
 Cells(1).CurrentRegion.Offset(UBound(sn) + 2, UBound(sn, 2) + 2) = sn
End Sub

If you doubleclick in the leftupper cell of the range that has to be parsed:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  sn = Target.CurrentRegion

  For j = 0 To UBound(sn) * UBound(sn, 2) - 1
   If InStr(sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1), "(") > 0 Then sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1) = Split(sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1), "(")(0)
  Next
       
  Target.CurrentRegion = sn
End Sub

NB. Put this code into the worksheet codemodule.

Hi snb,

I've been taking another look at your code and was wondering, is it possible to run the same code against a defined cell range?

I've done a little reading about CurrentRegion and I think what I gather from how it works is that it works on contiguous data from top left cell to bottom right cell. Is that correct?

So, really what I'm wondering therefore is as some of the data I want to alter with this method has clear row spaces between data sections (and I need that spacing to remain for presentation and formating). Can I specify in the code an entire cell range instead, say A1:H100 for example which would then result in the two types of data sitting to the right of the originals?

I've played around with the code to figure out how the OffSet works but am not sure how to go about replacing CurrentRegion if it is at all possible in the first place.

Thanks.

Originally Posted by snb

or use

Sub snb()
 sn = Cells(1).CurrentRegion
 For j = 0 To UBound(sn) * UBound(sn, 2) - 1
  If InStr(sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1), "(") > 0 Then sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1) = Split(sn(j \ UBound(sn, 2) + 1, j Mod UBound(sn, 2) + 1), "(")(0)
 Next
    
 Cells(1).CurrentRegion.Offset(, UBound(sn, 2) + 2) = sn
End Sub

@ tnx Kyle123, attachment updated