VBA Copying data in a cell to another

Copper Contributor
I am newer at creating VBa scripts. Need some help. I am working on creating a VBA script to copy data from a cell to another cell. Below is a sample data:

LIN**BP*6ZS52WA6AA~

SN1**2*EA*6~

So in this example the data that is in between the BP* ~ will be pasted in a separate cell. So the end result in the empty cell would be
6ZS52WA6AA
Similar to the data in between SN1** * * ~
The end result would be one cell would have 2 the next cell EA and the last cell 6.
14 Replies

@PostHill 

Why should 2 be returned from the second example, but not BP from the first example?

The reason is because I do not want to include the BP in a separate cell.  I am looking to put the data

that comes after the BP* and before the end of the ~ in a cell of its own.  So the example would be that the script would locate the data between the BP* and the ~ then put it in a blank cell on the sheet.  Looking to accomplish the same with the line SN1**2*EA*6~.  So in that example anything in between the SN1** and * would go into another cell so this example it would be the 2.  Then have the EA go into another blank cell and then the 6 would go into a final cell. 

 

 

@PostHill 

What is the "rule" behind this? How can we know that you do not want to return BP but you do want to return 2? Both are between ** and *.

I am trying to parse some data. I am trying to figure out how to pull that data after the BP* and before the ~ at the end of the cell. Blow is a few samples:
LIN**BP*6ZS52WA6AA~ - This cell data the VBA code would put the 6ZS52WA6AAin its own cell.
SN1**2*EA*6~ - This cell data would grab the 2 the EA and the 6 and put those into their own cells.
PRF*MW005667***200608~ - This cell data would pull and put the MW005667 in another cell
CLD*1*2***EA~
REF*SE*10000172176167310001~ - Then this cell I would be pulling the 10000172176167310001 and putt that in another cell.
REF*VT*NS100182~ - This one I would be grabbing the NS100182 and putting that into a cell.
HL*3*1*I~
LIN**BP*1VW50SD4AA~ - This is a sample where the process starts over again and I want to put the 1VW50SD4AA in a cell
SN1**3*EA*9~ - Same thing here with the 3, EA and the 9
PRF*MW005667***200608~ - The MW005667 would go into another cell
CLD*1*3***EA~
REF*SE*10000172175887210001~ The pull the 10000172175887210001 and put that into a cell
REF*VT*NS100255~ - Then the NS100255 gets put into another cell.

Trying to automate the process so I do not have to go through thousands of lines to manually copy the info I want to place in separate cells.

I hope this helps.

@PostHill 

I don't understand the logic of which parts should be extracted and which ones not.

sorry for any confusion.  I have attached a sample of the data in Column A and the the data in yellow is what I want to extract into the other fields.  I hope the visualization helps.

@PostHill 

So now you do NOT want to extract the 6 from A2?

My apologies you are correct. I had a mistype orginially

@PostHill 

You indicate in your sample workbook that the results should be in one row.

Do you want the results for the next group to the right of that, or do you want them on the next row?

I want to get the next group in the row below

@PostHill 

Try running this macro:

Sub Extract()
    Dim r As Long
    Dim m As Long
    Dim a() As String
    Dim t As Long
    Dim c As Long
    Dim n As Long
    Application.ScreenUpdating = False
    t = 1
    m = Range("A" & Rows.Count).End(xlUp).Row
    For r = 1 To m
        a = Split(Replace(Range("A" & r).Value, "~", ""), "*")
        ' Optional: write first part to column B
        Range("B" & r).Value = a(0)
        ' Extract parts
        Select Case a(0)
            Case "LIN"
                t = t + 1
                c = 3
                Cells(t, c).Value = "'" & a(3)
            Case "SN1"
                c = c + 1
                Cells(t, c).Value = "'" & a(2)
                c = c + 1
                Cells(t, c).Value = "'" & a(3)
            Case "PRF"
                c = c + 1
                Cells(t, c).Value = "'" & a(1)
            Case "CLD"
                ' Skip
            Case "REF"
                c = c + 1
                Cells(t, c).Value = "'" & a(2)
        End Select
        n = Application.Max(n, c)
    Next r
    Range("B1").Resize(1, n - 1).EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub
It worked great on the sample file but when I applied it to the master file I get the below section that needs debugging
Range("B" & r).Value = a(0)

@PostHill 

Are there blank cells in column A?

Yes there was. It worked perfectly. Thank you so much for your help.