Horizontal cycle (VBA)

[Fixed]

Hello!

I have some macro:

Sub bracketsSub()
    Dim arr()   As Variant
    Dim x       As Long
    
    x = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Cells(1, 1).Resize(x, 2).Value
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        arr(x, 2) = brackets(CStr(arr(x, 1)))
    Next x
    Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    Erase arr
End Sub
Private Function brackets(ByRef sss As String) As String
Dim aaa As Long '---
Dim bbb As Long '---
On Error GoTo Error_handler:
     aaa = InStr(sss, "(")
     bbb = InStr(aaa, sss, ")")
     brackets = Mid(sss, aaa + 1, bbb - aaa - 1)
Exit Function
Error_handler:
brackets = "-no-"
End Function

It's extract some text (first found text) from the brackets "()" from the strings in the "A" column and copy to "B" column.
What I should do to extract all texts from the brackets?

Example I want to get:

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD="align: center"]A
[/TD]
[TD="align: center"]B
[/TD]
[TD="align: center"]C
[/TD]
[TD="align: center"]D
[/TD]
[/TR]
[TR]
[TD="align: center"]1
[/TD]
[TD="align: center"](yes)(no)(don't know)<strike></strike>
[/TD]
[TD="align: center"]yes
[/TD]
[TD="align: center"]no
[/TD]
[TD="align: center"]don't know<strike></strike>
[/TD]
[/TR]
[TR]
[TD="align: center"]2
[/TD]
[TD="align: center"](yes)(no)<strike></strike>
[/TD]
[TD="align: center"]yes
[/TD]
[TD="align: center"]no
[/TD]
[TD="align: center"]-no-
[/TD]
[/TR]
[TR]
[TD="align: center"]3
[/TD]
[TD="align: center"](yes)<strike></strike>
[/TD]
[TD="align: center"]yes
[/TD]
[TD="align: center"]-no-<strike></strike>
[/TD]
[TD="align: center"]-no-<strike></strike>
[/TD]
[/TR]
</tbody>[/TABLE]

Help me please!

 

[pgc01]

Hi

Instead of a macro you could use text-to-columns to split the text.

 

[MickG]

Assuming your data start "A2", then try this for results in column "B,C & D"

[COLOR="Navy"]Sub[/COLOR] MG27Oct41
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Txt = Mid(Replace(Replace(Dn.Value, ")", ""), "(", ","), 2)
        Sp = Split(Txt, ",")
            Dn.Offset(, 1).Resize(, 3) = "-no-"
                [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                    Dn.Offset(, n + 1) = Sp(n)
                [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Truiz]

Wouldn't a Text to Column be much easier?

If you really want a UDF I wouldn't know how to help you, but there is this Macro I created that Could/Should be able to help you.

Sub HZ()Dim LastR As Long
Dim LastC As Long


LastR = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row
    
    'If your data has headers change A1 with A2 or whatever Row you want to start at also change Destination:=Range("B1") to match
    Range("A1:A" & LastR).TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="(", FieldInfo:=Array(Array(1, 9)), TrailingMinusNumbers:=True
LastC = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
         SearchDirection:=xlPrevious, LookIn:=xlValues).Column
    
    'Need to match the row were you started so if you changed A1 to A2 change B1 to B2 below
    q = Cells(LastR, LastC).Address
    With Range("B1", q)
    .Replace What:=")", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    .Replace What:="", Replacement:="-no-", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    End With
End Sub

 

[Fixed]

Thanx MickG, it works for sample from post #1 , but it don't work with another sample:


[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[TD="align: center"]D[/TD]
[/TR]
[TR]
[TD="align: center"]1[/TD]
[TD="align: center"](yes)---(no)--(I don't know)--some text[/TD]
[TD="align: center"]yes[/TD]
[TD="align: center"]no[/TD]
[TD="align: center"]don't know<strike></strike>[/TD]
[/TR]
[TR]
[TD="align: center"]2[/TD]
[TD="align: center"](yes)--(no)---some text[/TD]
[TD="align: center"]yes[/TD]
[TD="align: center"]no[/TD]
[TD="align: center"]-no-[/TD]
[/TR]
[TR]
[TD="align: center"]3[/TD]
[TD="align: center"]some text[/TD]
[TD="align: center"]-no-[/TD]
[TD="align: center"]-no-<strike></strike>[/TD]
[TD="align: center"]-no-[/TD]
[/TR]
</tbody>[/TABLE]

 

[Fixed]

Hi

Instead of a macro you could use text-to-columns to split the text.

Macro that I'm writing is some different from macro I showed.

 

[Fixed]

If you really want a UDF I wouldn't know how to help you, but there is this Macro I created that Could/Should be able to help you.

Truiz, I don't want a UDF if it don't work)
Thank you for help, but your macro don't work with another sample from post #5 , sorry for my mistake(

 

[MickG]

This works for both, but it will be limited depending how far you move the goal posts.!!!

[COLOR="Navy"]Sub[/COLOR] MG27Oct53
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Mch
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
Mch = Array("yes", "no", "don'[COLOR="Green"][B]t know")[/B][/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Dn.Offset(, 1).Resize(, 3) = "-no-"
        [COLOR="Navy"]For[/COLOR] n = 0 To 2
            [COLOR="Navy"]If[/COLOR] InStr(Dn.Value, Mch(n)) > 0 [COLOR="Navy"]Then[/COLOR]
                Dn.Offset(, n + 1) = Mch(n)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Rick Rothstein]

Here is another macro that you can consider...

[table="width: 500"]
[tr]
	[td]Sub SplitOutOfParentheses()
  Dim LastRow As Long
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B1:B" & LastRow) = Evaluate(Replace("IF(A1:A#="""","""",SUBSTITUTE(MID(A1:A#,2,LEN(A1:A#)-2),MID(LEFT(A1:A#&""("",FIND(""("",A1:A#&""("",2)),FIND("")"",A1:A#),[B][COLOR="#FF0000"]300[/COLOR][/B]),""(""))", "#", LastRow))
  Columns("B").TextToColumns , xlDelimited, , , False, False, False, False, True, "("
End Sub[/td]
[/tr]
[/table]

You did not give any indication how many characters maximum could possibly be in any one cell, so I assumed 300... if that is wrong, then change the one instance of 300 (shown in red in the text above... you might have to scroll horizontally to see it) to a value that is at least as big as the most characters you ever expect to have in a one cell.

 

[Fixed]

Thanx Rick, I've used your updated macro:

Sub SplitOutOfParentheses()
  Dim LastRow As Long
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B1:B" & LastRow) = Evaluate(Replace("IF(A1:A#="""","""",SUBSTITUTE(MID(A1:A#,2,LEN(A1:A#)-2),MID(LEFT(A1:A#&""("",FIND(""("",A1:A#&""("",2)),FIND("")"",A1:A#),[B]10000[/B]),""(""))", "#", LastRow))
  Columns("B").TextToColumns , xlDelimited, , , False, False, False, False, True, "("
End Sub

...and it don't work as I showed in sample from the #5 .