move string from array to new sheet

Question

The code below break the cells in image 1 into an array pictured in image 2. The new array is moved to start at AG. After that the program looks through the array and finds the words 'hello' and 'bye'. It takes those words and moves them into a new sheet and column pictured in image 3. Where I'm having trouble is that I want to still pull the strings 'hello' and 'bye' but I want to also pull the string directly before it from the array. In my example (image 3) I would've wanted it to read 'John Hello' instead of 'hello' on its own. What function would I use to extract the string before 'hello' or 'bye' also from the array?

Sub SplitWithFormat()
    Dim R As Range, C As Range
    Dim i As Long, V As Variant
    Dim varHorizArray As Variant
    Dim rge As Range
    Dim intCol As Integer
    Dim s As String
    
   
Set R = Range("d1", Cells(Rows.Count, "d").End(xlUp))
For Each C In R
    With C
        .TextToColumns Destination:=.Range("AD1"), DataType:=xlDelimited, _
        consecutivedelimiter:=True, Tab:=False, semicolon:=True, comma:=False, _
        Space:=True, other:=True, Otherchar:=vbLf

        Set rge = Selection
        varHorizArray = rge
        .Copy
        Range(.Range("AD1"), Cells(.Row, Columns.Count).End(xlToLeft)).PasteSpecial xlPasteFormats
    End With
Next C

Application.CutCopyMode = False

    For intCol = LBound(varHorizArray, 2) To UBound(varHorizArray, 2)
       Debug.Print varHorizArray(1, intCol)
    Next intCol
    
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    varHorizArray = Array("hello", "bye")
    
    Set NewSh = Worksheets.Add

    With Sheets("Sheet2").Range("AD1:AZ100")

    Rcount = 0

        For i = LBound(varHorizArray) To UBound(varHorizArray)

            
            Set Rng = .find(What:=varHorizArray(i), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rcount = Rcount + 1

                    Rng.Copy NewSh.Range("A" & Rcount)

                    
                    NewSh.Range("A" & Rcount).Value = Rng.Value

                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next i
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

UBound(your array)-1?? Edit: scratch that, you made this way more difficult than it needs be XD — findwindow
– findwindow, Commented Jul 1, 2016 at 21:11

Tim Williams · Accepted Answer · 2016-07-01 21:47:33Z

3

Option Explicit

Sub Tester()

    Dim c As Range, v As String, arr, x As Long, e
    Dim d As Range

    'EDIT: changed destination for results
    Set d = WorkSheets("Sheet2").Range("D2") '<<results start here

    For Each c In ActiveSheet.Range("A2:A10")
        v = Trim(c.Value)
        If Len(v) > 0 Then

            'normalize other separators to spaces
            v = Replace(v, vbLf, " ")
            'remove double spaces
            Do While InStr(v, "  ") > 0
                v = Replace(v, "  ", " ")
            Loop

            'split to array
            arr = Split(v, " ")
            For x = LBound(arr) To UBound(arr)
                e = arr(x)
                'see if array element is a word of interest
                If Not IsError(Application.Match(LCase(e), Array("hello", "bye"), 0)) Then
                    If x > LBound(arr) Then
                        d.Value = arr(x - 1) & " " & e 'prepend previous word
                    Else
                        d.Value = "??? " & e 'no previous word
                    End If
                    Set d = d.Offset(1, 0)
                End If
            Next x
        End If
   Next c
End Sub

edited Jul 1, 2016 at 21:47

answered Jul 1, 2016 at 21:22

Tim Williams

169k8 gold badges104 silver badges143 bronze badges

Sign up to request clarification or add additional context in comments.

3 Comments

Mátray Márk Over a year ago

I like this more than mine so +1 :)

johndoe253 Over a year ago

Thanks! The only things is I don't want to overwrite what I have so how can I move it to a new sheet?

johndoe253 Over a year ago

@TimWilliams Thank you!

Mátray Márk · Accepted Answer · 2016-07-01 21:25:16Z

Something like this?

Option Explicit

Sub strings()

Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim lookingForThese() As String


Set ws = ThisWorkbook.Worksheets(1)
Set rng = ws.Range(ws.Range("A1"), ws.Range("A1").End(xlDown))
ReDim lookingForThese(1 To 2)
lookingForThese(1) = "bye"
lookingForThese(2) = "hello"

For Each cell In rng

    Dim i As Integer
    Dim parts() As String

    'Split the string in the cell
    parts = Split(cell.Value, " ")
    'I'm parsing the parts to a 2. worksheet and the hello/bye + the word before those on a 3.
    For i = LBound(parts) To UBound(parts)

        Dim j As Integer
        ThisWorkbook.Worksheets(2).Cells(cell.Row, i + 1).Value = parts(i)
        For j = LBound(lookingForThese) To UBound(lookingForThese)

            If parts(i) = lookingForThese(j) Then
                If i <> LBound(parts) Then

                    ThisWorkbook.Worksheets(3).Cells(cell.Row, 1).Value = parts(i - 1) & " " & parts(i)
                Else

                    ThisWorkbook.Worksheets(3).Cells(cell.Row, 1).Value = parts(i)

                End If
            End If

        Next j
    Next i

Next cell

End Sub

Collectives™ on Stack Overflow

move string from array to new sheet

2 Answers 2

3 Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

3 Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related