VBA-Macro to find value inside of string & copy to cell/sheet

[HesterPrynne]

Hello there!,

On sheet i have data in column A. It looks like:

:20

:23B

:32A:090216EUR4

:33B

:50A:

:52A:

:53A:

:54A:

:56A:

:57A:

:59:/10000101

:70:

:71A:

:72:

:77B

<tbody>
</tbody>

And I would like to transform it with help of macros into :
Macros finds row , containing characters":32A:" and copies only currency - in example it is USD,EUR(to another sheet or to next cell, lets say D2).
Than macros finds row , containing characters":59:" and copies all characters that follows after "/"(or ":59:/", lets say E2).
And than it should match Currency(row containing ":32A:") with account (row containing ":59:/") when complete matching within one pair, goes to next and so on.
It should look like:

EUR 10000101

Thanks for your help in advance!

****** id="cke_pastebin" style="position: absolute; top: 40px; width: 1px; height: 1px; overflow: hidden; left: -1000px;">

:32A:100216USD5

<tbody>
</tbody>

 

[HesterPrynne]

Hi again guys, no ideas at all? as of now Im using such formulas to extract nedeed fragments from text:

=(MID(Sheet1!A951,SEARCH(":59:",Sheet1!A951)+5,20))
And
=MID(Sheet1!A14,SEARCH(":32A:",Sheet1!A14)+11,3)

But it is very inconvenient and time consuming. Im newbie in VBA and its hard to make solution at my own.

 

[S_Wish]

Hi, it is not very clear where other data is? you have the same data looping on column A?
32
59
...
32
59
and again till last row on sheet?

 

[S_Wish]

If answer to my question is Yes then here you are

Sub DoSmth()
    
    Dim WS As Object
    Dim i, LastRow, CopyRow As Long
    Dim IsEnd As Boolean
    
    Application.ScreenUpdating = False
    Set WS = ActiveSheet 'you can point any name like
                        ' ... = activeworkbook.sheets("my name")
    LastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
    IsEnd = True
    i = 1
    CopyRow = 1
    While IsEnd
    If Left(WS.Range("A" & i).Value, 5) = ":32A:" Then
    WS.Range("D" & CopyRow).Value = Mid(WS.Range("A" & i).Value, 12, 3) & " "
    End If
    
    If Left(WS.Range("A" & i).Value, 5) = ":59:/" Then
    WS.Range("D" & CopyRow).Value = WS.Range("D" & CopyRow).Value & _
    Right(WS.Range("A" & i).Value, Len(WS.Range("A" & i).Value) - 5)
    CopyRow = CopyRow + 1
    End If
    
    If i > LastRow Then
    IsEnd = False
    End If
    i = i + 1
    Wend
    
    Application.ScreenUpdating = True
    
End Sub

 

[HesterPrynne]

Hi, data looks like

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

:20

:23B

:32A:090216EUR4

:33B

:50A:

:52A:

:53A:

:54A:

:56A:

:57A:

:59:/10000101

:70:

:71A:

:72:

:77B --------------------- :20 :23B :32A:090216EUR4 :33B :50A: :52A: :53A: :54A: :56A: :57A: :59:/10000101 :70: :71A: :72: :77B ----------------- :20 :23B :32A:090216EUR4 :33B :50A: :52A: :53A: :54A: :56A: :57A: :59:/10000101 :70: :71A: :72: :77B --------------------- And so on. On average its about 60-70 blocks <tbody> </tbody> <tbody> </tbody>

<tbody>
</tbody>

 

[S_Wish]

Then my code should help
to avoid losses if it works not correctly firstly save copy and try to run my macro there
PS notify when got results^_^

 

[HesterPrynne]

Thanks it works and it is fabulous! Is there any possibility to split results in column D? i mean that now it looks like 10000101EUR and to make change into 10000101 | EUR in two different cells?

 

[MrIfOnly]

Can I just chime in to say that I love your username?! I'm a big Scarlet Letter fan!

 

[S_Wish]

of course, you can:
this IF statement writes EUR, USD and so on change highlighted one as you wish

    If Left(WS.Range("A" & i).Value, 5) = ":32A:" Then
    WS.Range("F" & CopyRow).Value = Mid(WS.Range("A" & i).Value, 12, 3) & " "
    End If

and this is for numbers (green you won`t need if cells 10000101 and USD are separeted)

    If Left(WS.Range("A" & i).Value, 5) = ":59:/" Then
    WS.Range("D" & CopyRow).Value = WS.Range("D" & CopyRow).Value & _  
    Right(WS.Range("A" & i).Value, Len(WS.Range("A" & i).Value) - 5)
    CopyRow = CopyRow + 1
    End If

for cols D and F:
first block red D change to F, delete green
second block delete green (notify, that underscore "_" must be left)

 

[Peter_SSs]

Welcome to the MrExcel board!

If the currency always starts at position 12 and the ":32A:" & ":59:" codes always come at the start of the cell, as S_Wish has allowed for, then you could also try this code (in a copy of your workbook)

Sub GetData()
  Dim a As Variant, b As Variant, e As Variant
  Dim k As Long
  
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For Each e In a
    Select Case True
      Case Left(e, 5) = ":32A:"
        k = k + 1: b(k, 1) = Mid(e, 12, 3)
      Case Left(e, 4) = ":59:"
        b(k, 2) = Split(e, "/")(1)
    End Select
  Next e
  With Range("D2:E2").Resize(k)
    .Value = b
    .Columns.AutoFit
  End With
End Sub

@S_Wish
I'm not sure if you are aware that the following line in your code only declares CopyRow as Long. The other two variables will be Variant type.
To declare them all as Long you need to specify for each one in the line - as I have done with my a, b and e variables in my code.

Dim i, LastRow, CopyRow As Long