VBA Code to Find Words with $ at The Beginning and then paste in another sheet

[OilEconomist]

Thanks in advance for your assistance as I will give feedback regardless whether it works or not.

Apologies if the requested or similar code exists as I have searched the internet and this forum, but have not been successful.

I would like to search an existing sheet for all the words/tickers that begin with a $ and return the entire word less the $, do a different sheet. So for example,

Cell A3: $SPY and $QQQ are going up tomorrow.
Cell A4: $VIX and $MRNA will be on a downward trend.

I would like the following posted in the same workbook in a sheet called "Tickers"
Cell A2: SPY
Cell A3: QQQ
Cell A4: VIX
Cell A5: MRNA

Here is the start of my code:

Sub GetTicker()

'________________________________________________________________________________________________________
'Turn off alerts, screen updates, and automatic calculation
        'Turn off Display Alerts
            Application.DisplayAlerts = False

        'Turn off Screen Update
            Application.ScreenUpdating = False

        'Turn off Automatic Calculations
            Application.Calculation = xlManual


'________________________________________________________________________________________________________
'Dimensioning
    Dim LastRow As Long
    
    Dim Ticker As String






'________________________________________________________________________________________________________
'Find the LastRow
    Sheets("Sheet1").Activate
        LastRow1 = Cells.Find(What:="*", after:=Range("A1"), LookAt:=xlPart, _
            LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
            MatchCase:=False).Row
    End With
    'MsgBox LastRow


'________________________________________________________________________________________________________
'Loop through and find all the ones with the $ at the beginning of the words
    
    For i = 1 To LastRow1
        Sheets("Sheet1").Activate
            
            'This is the code that is missing
            'Find all values in the sheet that begins with a $ and is followed by letters and then just store the_
                'letters in string "Ticker"
   
                
    
    
        Sheets("Sheet2").Activate
            'Find the last row and past the ticker into it.
                LastRow2 = Cells.Find(What:="*", after:=Range("A1"), LookAt:=xlPart, _
                    LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
                    
                Cells("A" & LastRow2).Value = Ticker
    
    Next i

'________________________________________________________________________________________________________
'Turn on alerts, screen updates, and calculate

        'Turn On Display Alerts
            Application.DisplayAlerts = True

        'Turn on Screen Update
            Application.ScreenUpdating = True

        'Turn off Automatic Calculations
            Calculate

'Place the curser in cell



End Sub

 

[Rick Rothstein]

But you say there could be other $ signs that you do not want... those would always be numbers only then?

 

[OilEconomist]

They will always have letters and I felt that this was clear when I indicated "search an existing sheet for all the words/tickers that begin with a $ and return the entire word less the $"

The values can consist of letters, numbers, or a combination of both. What I'm searching through is a stock ticker.

Thanks!

My objective is to copy just items that consist of letters, or a combination of both. What I'm searching through is a stock ticker.

 

[OilEconomist]

But you say there could be other $ signs that you do not want... those would always be numbers only then?

My objective is to copy just items that consist of letters, or a combination of both letters and numbers. What I'm searching through is a stock ticker.

If "$" sign is followed by a number, like $50,000 or $100, I do not want to copy it.

 

[OilEconomist]

Sub test() Dim a, b, m As Variant Dim i, ii As Long With Sheets("Sheet1") a = .Cells(3, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 2) End With ReDim b(1 To UBound(a) * 2) ii = 1 With CreateObject("VBScript.RegExp") .Global = True .Pattern = "\$\w+" For i = 1 To UBound(a) Set m = .Execute(a(i, 1)) b(ii) = Mid(m(0), 2): b(ii + 1) = Mid(m(1), 2): ii = ii + 2 Next End With Sheets("Tickers").Cells(2, 1).Resize(UBound(b)) = Application.Transpose(b) End Sub

Thanks so much.

When I ran it, I received the message the message "Run-time error '5': Invalid procedure call or argument" on the following section

b(ii) = Mid(m(0), 2)

of the following line

b(ii) = Mid(m(0), 2): b(ii + 1) = Mid(m(1), 2): ii = ii + 2

 

[Rick Rothstein]

Give this macro a try...

Sub GetDollarSignWords()
  Dim Arr As Variant
  Application.ScreenUpdating = False
  Arr = Split(Join(Application.Transpose(Sheets("Sheet1").Range("A1", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)))))
  Arr = Filter(Arr, "$")
  Sheets("Tickers").Range("A2").Resize(UBound(Arr) + 1) = Application.Transpose(Arr)
  Sheets("Tickers").Columns("A").Replace "$", "", xlPart, , , , False, False
  Sheets("Tickers").Columns("A").SpecialCells(xlConstants, xlNumbers).Delete xlShiftUp
  Application.ScreenUpdating = True
End Sub

 

[OilEconomist]

Sub GetDollarSignWords() Dim Arr As Variant Application.ScreenUpdating = False Arr = Split(Join(Application.Transpose(Sheets("Sheet1").Range("A1", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp))))) Arr = Filter(Arr, "$") Sheets("Tickers").Range("A2").Resize(UBound(Arr) + 1) = Application.Transpose(Arr) Sheets("Tickers").Columns("A").Replace "$", "", xlPart, , , , False, False Sheets("Tickers").Columns("A").SpecialCells(xlConstants, xlNumbers).Delete xlShiftUp Application.ScreenUpdating = True End Sub

@Rick Rothstein Thanks so much.

So it does leave space rows, but I think it's because when the MS Word document is converted to a pdf file, it leaves spaces between some of the $ and words. So what happens is the macro will copy the $ and then remove it and leave a blank space. Is there a way to first check if there is a blank space after the $ and if so, eliminate it. Also, I think it eliminates whole numbers like $4 or $400, but not $0.40. Is there a way to eliminate values like $0.40?

You are definitely very advanced of the advanced like many of the folks who responded versus a novice like me. What I'm afraid of is if I make additions to this, and I have a question, others may not be able to resolve it.

 

[Rick Rothstein]

Is there a way to eliminate values like $0.40?

Give this a try...

Sub GetDollarSignWords()
  Dim Arr As Variant
  Application.ScreenUpdating = False
  Arr = Split(Join(Application.Transpose(Sheets("Sheet1").Range("A1", Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp)))))
  Arr = Filter(Arr, "$")
  Sheets("Tickers").Range("A2").Resize(UBound(Arr) + 1) = Application.Transpose(Arr)
  Sheets("Tickers").Columns("A").Replace "$ ", "$", xlWhole, , , , False, False
  Sheets("Tickers").Columns("A").Replace "$", "", xlPart, , , , False, False
  Sheets("Tickers").Columns("A").SpecialCells(xlConstants, xlNumbers).Delete xlShiftUp
  Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Thanks for the additional information.

it leaves spaces between some of the $ and words.

This could still be an issue as that 'space' may or may not be a normal space. However, give this one a try.
This does not have the 65,000 rows restriction and checks all columns as requested.

Sub Get_Tickers_v2()
  Dim RX As Object, m As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = " \$ *[A-Z].+?\b"
  ReDim b(1 To Rows.Count, 1 To 1)
  a = Sheets("Sheet1").UsedRange
  For j = 1 To UBound(a, 2)
    For i = 1 To UBound(a)
      For Each m In RX.Execute(" " & a(i, j))
        k = k + 1
        b(k, 1) = LTrim(Mid(m, 3))
      Next m
    Next i
  Next j
  Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k).Value = b
End Sub

If still failures, please remember ..

For the future I suggest that you investigate XL2BB for providing sample data that shows the variety of data that might be encountered & expected results. As well as showing variety, it also makes it easier for helpers to understand just what you have & where it is and can be easily copied for testing.

 

[OilEconomist]

Thanks for the additional information.

This could still be an issue as that 'space' may or may not be a normal space. However, give this one a try.
This does not have the 65,000 rows restriction and checks all columns as requested.

Sub Get_Tickers_v2()
  Dim RX As Object, m As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long

  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = " \$ *[A-Z].+?\b"
  ReDim b(1 To Rows.Count, 1 To 1)
  a = Sheets("Sheet1").UsedRange
  For j = 1 To UBound(a, 2)
    For i = 1 To UBound(a)
      For Each m In RX.Execute(" " & a(i, j))
        k = k + 1
        b(k, 1) = LTrim(Mid(m, 3))
      Next m
    Next i
  Next j
  Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k).Value = b
End Sub

If still failures, please remember ..

Thanks @Peter_SSs. I'll try to check when I get a chance.

 

[Peter_SSs]

Thanks @Peter_SSs. I'll try to check when I get a chance.

Cheers. No problem.