extract text from input box

[ferrigeu]

hi all
i have the below code that works perfect to find and highlight text that is entered in an Input Box
is there a way to extract that input and list it in a separate tab, starting e.g. at A1.
each entry in the Input Box is separated by comma.
first item would be in A1, second in A2, etc.
doable?

thks

Sub HighlightStrings()
'Updateby Extendoffice

'sort the data
Call sorting

'change font back to black
ActiveSheet.Range("g12:h22500").Select
Range("g12:h22500").Font.ColorIndex = 1

'set parameters
Dim Rng As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
Dim xFNum As Integer
Dim xArrFnd As Variant
Dim xStr As String

cFnd = InputBox("Please enter your Search Criteria(s)" & vbCrLf & "Separated by comma" & vbCrLf & "-> Search is not Case Sensitive" & vbCrLf & " ")
If Len(cFnd) < 1 Then Exit Sub

'not case sensitive
xArrFnd = Split(UCase(cFnd), ",")

'case sensitive
'xArrFnd = Split(cFnd, ",")

'define the range of the data
ActiveSheet.Range("g12:h22500").Select

For Each Rng In selection
With Rng
For xFNum = 0 To UBound(xArrFnd)
xStr = xArrFnd(xFNum)
y = Len(xStr)
m = UBound(Split(UCase(Rng.Value), UCase(xStr)))

'case sensitive
'm = UBound(Split(Rng.Value, xStr))

If m > 0 Then
xTmp = ""
For x = 0 To m - 1
xTmp = xTmp & Split(UCase(Rng.Value), UCase(xStr))(x)

'case sensitive
'xTmp = xTmp & Split(UCase(Rng.Value), UCase(xStr))(x)

.Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
xTmp = xTmp & xStr
Next

End If
Next xFNum
End With
Next Rng

Application.ScreenUpdating = True

'cursor goes back
Range("a1").Select

End Sub
Sub sorting()
'
' sorting Macro
'
    Range("g12:h22500").Select
    ActiveWorkbook.Worksheets("Almanac").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Almanac").Sort.SortFields.Add Key:=Range( _
        "G12:G22500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Almanac").Sort.SortFields.Add Key:=Range( _
        "H12:H22500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Almanac").Sort
        .SetRange Range("G11:H5257")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   

'Call Return_1_2

End Sub

 

[DanteAmor]

After this line:

xArrFnd = Split(UCase(cFnd), ",")

Put this line:

Sheets("extract").Range("A1").Resize(UBound(xArrFnd) + 1).Value = Application.Transpose(xArrFnd)

Fit "extract" to the name of your sheet.

 

[ferrigeu]

paaaafect - THANK YOU !