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

trikiash

New Member
Joined
Feb 22, 2020
Messages
4
Office Version
2016
Platform
Windows
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.
VBA example.PNG
 

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

juddaaaa

Board Regular
Joined
Jan 4, 2020
Messages
208
Office Version
365
Platform
Windows
Here's something that should work
VBA Code:
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
ABCDEFG
1Raw dataAppleBananaPineappleGrapePear
2Red Apple
3Yellow banana
4purple pineapple
5green grapes
6green apple
7green banana
8yellow apple
9brown pear
10yellow pear
11Red Apple
12
Sheet1


After
Book1
ABCDEFG
1Raw dataAppleBananaPineappleGrapePear
2Red AppleYellow bananapurple pineapplegreen grapesbrown pear
3green applegreen bananayellow pear
4yellow apple
5
6
7
Sheet1
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,818
Office Version
365, 2019, 2016
Platform
Windows
Power Query.

Book1
ABCDEFG
1Raw dataAppleBananaPineappleGrapesPear
2Red AppleRedYellowPurpleGreenBrown
3Yellow bananaGreenGreenYellow
4purple pineappleYellow
5green grapesRed
6green apple
7green banana
8yellow apple
9brown pear
10yellow pear
11Red Apple
Sheet4


Code:
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

Well-known Member
Joined
Jul 14, 2008
Messages
2,818
Office Version
365, 2019, 2016
Platform
Windows
Another way with VBA.



VBA Code:
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

New Member
Joined
Feb 22, 2020
Messages
4
Office Version
2016
Platform
Windows
Thank you all for your great help!! I REALLY appreciate it!!
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,105,930
Messages
5,508,172
Members
408,669
Latest member
AgsikapAko

This Week's Hot Topics

Top