将字符串从数组移动到新工作表

Question

下面的代码将图像1中的单元格分成图像2中所示的阵列。新阵列将移动到AG处开始。之后，程序查看数组并找到“hello”和“bye”字样。它需要这些单词并将它们移动到图3中所示的新工作表和列中。我遇到麻烦的是我仍然想要拉出字符串'hello'和'bye'但我想在之前直接拉出字符串它来自阵列。在我的例子中（图3），我希望它能够单独阅读'John Hello'而不是'hello'。我还会使用什么函数从数组中'hello'或'bye'之前提取字符串？

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​​

Answer 1

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

Answer 2

这样的东西？

选项明确

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