Need VBA to find terms in column A and move the data in the cell to another column

[trikiash]

Hi all, I'm trying to self teach myself how to do this, and I cannot figure this out. Attached is an example of what I want to learn. If I have column A as my raw data, I want to have a macro that will search, for example, "apple" and move the data in the cell over to column B, search A for "banana", move to C, etc....

I feel that it's a simple task, but it's driving me nuts. In a real life application, I will likely have several hundred rows of data in "A", and would like to be able to search and sort it into the columns.

Thank you for anyone that can help me with this, greatly appreciated.

 

[juddaaaa]

Here's something that should work

Sub SortToColumns()
  Dim sht As Worksheet, RegExp As Object, rw As Range, cl As Range, lastrowA As Long, lastrow As Long, lastcol As Long
  Dim colAry As Variant, i As Long

  Set sht = Sheets("Sheet1") '<-- Name of your worksheet
  Set RegExp = CreateObject("VBScript.RegExp")

  lastrowA = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
  lastcol = sht.Cells(1, sht.Columns.Count).End(xlToLeft).Column

  For Each rw In sht.Range("A2", "A" & lastrowA)
    With RegExp
      .IgnoreCase = True
    
      For Each cl In Range(sht.Cells(1, 1), sht.Cells(1, lastcol))
        .Pattern = "\b" & cl
        If .Test(rw) Then
          lastrow = sht.Cells(sht.Rows.Count, cl.Column).End(xlUp).Row
          rw.Cut sht.Cells(lastrow, cl.Column).Offset(1)
        End If
      Next cl
    End With
  Next rw
End Sub

Before

Book1
	A	B	C	D	E	F	G
1	Raw data	Apple	Banana	Pineapple	Grape	Pear
2	Red Apple
3	Yellow banana
4	purple pineapple
5	green grapes
6	green apple
7	green banana
8	yellow apple
9	brown pear
10	yellow pear
11	Red Apple
12
Sheet1

After

Book1
	A	B	C	D	E	F	G
1	Raw data	Apple	Banana	Pineapple	Grape	Pear
2		Red Apple	Yellow banana	purple pineapple	green grapes	brown pear
3		green apple	green banana			yellow pear
4		yellow apple
5
6
7
Sheet1

 

[lrobbo314]

Power Query.

Book1
	A	B	C	D	E	F	G
1	Raw data		Apple	Banana	Pineapple	Grapes	Pear
2	Red Apple		Red	Yellow	Purple	Green	Brown
3	Yellow banana		Green	Green			Yellow
4	purple pineapple		Yellow
5	green grapes		Red
6	green apple
7	green banana
8	yellow apple
9	brown pear
10	yellow pear
11	Red Apple
Sheet4

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Capitalized Each Word" = Table.TransformColumns(Source,{{"Raw data", Text.Proper, type text}}),
    #"Split Column by Delimiter" = Table.SplitColumn(#"Capitalized Each Word", "Raw data", Splitter.SplitTextByDelimiter(" ", QuoteStyle.Csv), {"Raw data.1", "Raw data.2"}),
    #"Grouped Rows" = Table.Group(#"Split Column by Delimiter", {"Raw data.2"}, {{"Count", each _, type table [Raw data.1=text, Raw data.2=text]}}),
    #"Added Custom" = Table.AddColumn(#"Grouped Rows", "Custom", each Text.Combine(Table.Column([Count],"Raw data.1"),",")),
    #"Removed Columns" = Table.RemoveColumns(#"Added Custom",{"Count"}),
    #"Split Column by Delimiter1" = Table.SplitColumn(#"Removed Columns", "Custom", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), {"Custom.1", "Custom.2", "Custom.3", "Custom.4"}),
    #"Transposed Table" = Table.Transpose(#"Split Column by Delimiter1"),
    #"Promoted Headers" = Table.PromoteHeaders(#"Transposed Table", [PromoteAllScalars=true]),
    #"Changed Type" = Table.TransformColumnTypes(#"Promoted Headers",{{"Apple", type text}, {"Banana", type text}, {"Pineapple", type text}, {"Grapes", type text}, {"Pear", type text}})
in
    #"Changed Type"

 

[lrobbo314]

Another way with VBA.

Sub bbs()
Dim sd As Object: Set sd = CreateObject("Scripting.Dictionary")[RANGE=rs:10|cs:8|w:Book1 (version 2).xlsb|cls:xl2bb-120|s:Sheet5|tw:762][XR][XH][/XH][XH=w:48]A[/XH][XH=w:48]B[/XH][XH=w:48]C[/XH][XH=w:124]D[/XH][XH=w:124]E[/XH][XH=w:124]F[/XH][XH=w:124]G[/XH][XH=w:124]H[/XH][/XR][XR][XH]1[/XH][XD=h:l|fw:b|ch:14.5]Raw data[/XD][XD][/XD][XD][/XD][XD=h:l|fw:b]APPLE[/XD][XD=h:l|fw:b]BANANA[/XD][XD=h:l|fw:b]PINEAPPLE[/XD][XD=h:l|fw:b]GRAPES[/XD][XD=h:l|fw:b]PEAR[/XD][/XR][XR][XH]2[/XH][XD=h:l|ch:14.5]Red Apple[/XD][XD][/XD][XD][/XD][XD=h:l]RED[/XD][XD=h:l]YELLOW[/XD][XD=h:l]PURPLE[/XD][XD=h:l]GREEN[/XD][XD=h:l]BROWN[/XD][/XR][XR][XH]3[/XH][XD=h:l|ch:14.5]Yellow banana[/XD][XD][/XD][XD][/XD][XD=h:l]GREEN[/XD][XD=h:l]GREEN[/XD][XD][/XD][XD][/XD][XD=h:l]YELLOW[/XD][/XR][XR][XH]4[/XH][XD=h:l|ch:14.5]purple pineapple[/XD][XD][/XD][XD][/XD][XD=h:l]YELLOW[/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][/XR][XR][XH]5[/XH][XD=h:l|ch:14.5]green grapes[/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][/XR][XR][XH]6[/XH][XD=h:l|ch:14.5]green apple[/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][/XR][XR][XH]7[/XH][XD=h:l|ch:14.5]green banana[/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][/XR][XR][XH]8[/XH][XD=h:l|ch:14.5]yellow apple[/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][/XR][XR][XH]9[/XH][XD=h:l|ch:14.5]brown pear[/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][/XR][XR][XH]10[/XH][XD=h:l|ch:14.5]yellow pear[/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][XD][/XD][/XR][/RANGE]
Dim AR() As Variant: AR = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim sp() As String
Dim t() As String
Dim col As Integer: col = 4

For i = 1 To UBound(AR)
    sp = Split(UCase(AR(i, 1)), " ")
    If InStr(sd(sp(1)), sp(0)) > 0 Then
    Else
        sd(sp(1)) = sd(sp(1)) & ";" & sp(0)
    End If
Next i

Range("D1").Resize(1, sd.Count).Value = sd.keys
For Each k In sd.keys
    t = Split(sd(k), ";")
    For i = 1 To UBound(t)
        Cells(i + 1, col).Value = t(i)
    Next i
    col = col + 1
Next k

End Sub

 

[trikiash]

Thank you all for your great help!! I REALLY appreciate it!!