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

OilEconomist

Active Member
Joined
Dec 26, 2016
Messages
421
Office Version
  1. 2019
Platform
  1. Windows
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:


VBA 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
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Split the string and find the words that start with $
VBA Code:
Sub Button1_Click()
    Dim rng As Range, Lstrw As Long, c As Range
    Dim SpltRng As Range
    Dim i As Integer
    Dim Orig As Variant
    Dim txt As String
    Dim sh As Worksheet
    Dim ws As Worksheet
    
    Set sh = Sheets("Tickers")
    Set ws = Sheets("Sheet1")
    
    With ws
        Lstrw = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set rng = .Range("A2:A" & Lstrw)

        For Each c In rng.Cells
            Set SpltRng = c
            txt = SpltRng.Value
            Orig = Split(txt, " ")

            For i = 0 To UBound(Orig)
                If Left(Orig(i), 1) = "$" Then
                    sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1) = Right(Orig(i), Len(Orig(i)) - 1)
                End If
            Next i
        Next c
    End With
    
End Sub
 
Upvote 0
Hi OilEconomist,

You can use below code: (see image)

Sub GetTicker()
'Dimensioning
Dim LastRow As Integer, i As Integer, Ticker As String, nextRow As Integer, word As String
Dim searchStart As Integer, searchIndex As Integer, myString As String
nextRow = 2


'________________________________________________________________________________________________________
'Find the LastRow
LastRow = WorksheetFunction.CountA(Worksheets("Sheet2").Range("A:A"))
'________________________________________________________________________________________________________
'Loop through and find all the ones with the $ at the beginning of the words

For i = 2 To LastRow
searchStart = 1
myString = Worksheets("Sheet2").Range("A" & i)
Do
searchIndex = InStr(myString, " ")

If searchIndex <> 0 Then
word = Mid(myString, searchStart, searchIndex - searchStart)
Else
word = myString
End If

If Left(word, 1) = "$" Then
Worksheets("Tickers").Range("A" & nextRow) = Mid(word, 2)
nextRow = nextRow + 1
End If
If searchIndex = 0 Then Exit Do
myString = Mid(myString, searchIndex + 1)

Loop

Next i
End Sub
 

Attachments

  • result.PNG
    result.PNG
    8.9 KB · Views: 6
  • sentences.PNG
    sentences.PNG
    15.5 KB · Views: 7
Upvote 0
And one more option
VBA Code:
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
 
Upvote 0
It isn't clear whether the data to be scanned in Sheet1 is all in one column or could be in multiple columns.
We also don't know whether every cell has exactly two tickers like your samples, whether there could be blank cells in the range to be checked, whether $ symbols could occur elsewhere in the data etc.
Allowing for some of those variations, but assuming data is in a single column (A) this would be my suggestion for finding the tickers and entering them in Sheet2.

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.

VBA Code:
Sub Get_Tickers()
  Dim RX As Object, m As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
  
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = " \$.+?\b"
  ReDim b(1 To Rows.Count, 1 To 1)
  With Sheets("Sheet1")
    a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    For Each m In RX.Execute(" " & a(i, 1))
      k = k + 1
      b(k, 1) = Mid(m, 3)
    Next m
  Next i
  Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k).Value = b
End Sub
 
Upvote 0
Hi OilEconomist,

You can use below code: (see image)

Sub GetTicker()
'Dimensioning
Dim LastRow As Integer, i As Integer, Ticker As String, nextRow As Integer, word As String
Dim searchStart As Integer, searchIndex As Integer, myString As String
nextRow = 2


'________________________________________________________________________________________________________
'Find the LastRow
LastRow = WorksheetFunction.CountA(Worksheets("Sheet2").Range("A:A"))
'________________________________________________________________________________________________________
'Loop through and find all the ones with the $ at the beginning of the words

For i = 2 To LastRow
searchStart = 1
myString = Worksheets("Sheet2").Range("A" & i)
Do
searchIndex = InStr(myString, " ")

If searchIndex <> 0 Then
word = Mid(myString, searchStart, searchIndex - searchStart)
Else
word = myString
End If

If Left(word, 1) = "$" Then
Worksheets("Tickers").Range("A" & nextRow) = Mid(word, 2)
nextRow = nextRow + 1
End If
If searchIndex = 0 Then Exit Do
myString = Mid(myString, searchIndex + 1)

Loop

Next i
End Sub
Thanks. I was having a bit of trouble. I put the code together and I'm getting a run time error. Do you see where I may have used the code incorrectly? I modified and input where the starts "*****************".


VBA 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 Integers
        Dim SearchStart As Integer
        Dim i As Integer
        Dim NextRow As Integer
        Dim SearchIndex As Integer
    
    'Dim Longs
        Dim LastRow1 As Long
        Dim LastRow2 As Long
    
    'Dim Strings
        Dim Ticker As String
        Dim MyString As String
        Dim Word As String


'________________________________________________________________________________________________________
'Setting Values
    NextRow = 2


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

'________________________________________________________________________________________________________
'Loop through and find all the ones with the $ at the beginning of the words
    
    For i = 1 To LastRow1
        Sheets("Watch.List").Activate


    '**************************************************************************
        SearchStart = 1
        MyString = Sheets("Watch.List").Range("A" & i)
        Do
        SearchIndex = InStr(MyString, " ")
        
        If SearchIndex <> 0 Then
        Word = Mid(MyString, SearchStart, SearchIndex - SearchStart)
        Else
        Word = MyString
        End If
        
        If Left(Word, 1) = "$" Then
            Sheets("Watch.List").Range("A" & NextRow) = Mid(Word, 2)
            NextRow = NextRow + 1
        End If
        
        If SearchIndex = 0 Then Exit Do
        MyString = Mid(MyString, SearchIndex + 1)

        Loop
    '**************************************************************************
    
    '______________________________________________________________________________________________
        'Paste the "Ticker" into the Worksheet "Tickers"
        
        Sheets("Tickers").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
                
                'Will not paste in column C versus A
                Cells("C" & 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
 
Upvote 0
If you have less than 65,500 rows of data on Sheet1, then this macro should also work...
VBA Code:
Sub GetDollarSignWords()
  Dim Arr As Variant
  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
End Sub
 
Last edited:
Upvote 0
It isn't clear whether the data to be scanned in Sheet1 is all in one column or could be in multiple columns.
We also don't know whether every cell has exactly two tickers like your samples, whether there could be blank cells in the range to be checked, whether $ symbols could occur elsewhere in the data etc.
Allowing for some of those variations, but assuming data is in a single column (A) this would be my suggestion for finding the tickers and entering them in Sheet2.

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.

VBA Code:
Sub Get_Tickers()
  Dim RX As Object, m As Object
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = " \$.+?\b"
  ReDim b(1 To Rows.Count, 1 To 1)
  With Sheets("Sheet1")
    a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    For Each m In RX.Execute(" " & a(i, 1))
      k = k + 1
      b(k, 1) = Mid(m, 3)
    Next m
  Next i
  Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(k).Value = b
End Sub
@Peter_SSs Thanks for your response and apologies if my request was vague. I am currently working with of the other solutions as you can see above, but I tried your code. It worked, but:
(1) when a number had a $ in front of it, it copied the number. My objective is to copy just items with letters.

(2) when the data was pasted into the sheet, it at times it would leave a blank row.

Here are responses to your questions:
• Q: It isn't clear whether the data to be scanned in Sheet1 is all in one column or could be in multiple columns.
• A: It's all in column 1, but I would like to check all cells in the case there are additional columns.

• Q: We also don't know whether every cell has exactly two tickers like your samples:
• A: No. There number of tickers varies and is not always 2.

• Q: whether there could be blank cells in the range to be checked,
• A: Yes there could be blank cells.

• Q: whether $ symbols could occur elsewhere in the data etc.
• A: Yes. It can occur elsewhere.
 
Upvote 0
(1) when a number had a $ in front of it, it copied the number. My objective is to copy just items with letters.
You need to mention things like this in your original postings. To be clear... will any of the values you do want every have a number embedded within the letters or are the values always be all letters?
 
Upvote 0
You need to mention things like this in your original postings. To be clear... will any of the values you do want every have a number embedded within the letters or are the values always be all letters?
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!
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,528
Messages
6,114,154
Members
448,553
Latest member
slaytonpa

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top