First Post: Macro / VBA to Move Entire Rows to New Sheets Based on Multiple Criteria From a List In A Separate Column

jholly1984

New Member
Joined
Sep 29, 2020
Messages
11
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
Hi everyone,

First I just want to say thank you to everyone who has been part of this site and community over the years. I have learned a ton and it is very much appreciated.

For this post, I am currently working on a problem that I have been unable to fully solve. There have been others posts on here and on Youtube that look at moving rows to another sheet based on criteria... but I have not seen one that looks at moving cells to different sheets based on dynamic criteria in a list. Hoping someone might be able to help.

Here is a quick view of what my sheet looks like:

ecel.JPG


Goal: I would like to be able to copy all rows to a new sheet where the keyword in column a CONTAINS the filter word in column H. Each filter in H would need to have its own sheet.

So... go through column A, identify all keywords that contain "laptop" and copy them to a new sheet called "Laptop". Then do the same each of the filter words in column H and create new sheets for each.

I have seen some options that move based on a specific cell value or a date.. but I have not been able to find anything that a) checks based on a full list of values in a column or b) extracts data based on if the cell 'contains' the filter).

I am hopnig the macros can identify and group the keyword sets automatically vs having to manually filter and assign a category in a separate column.

Hope that makes sense. Thank you for your time. Very much appreciated.
 

Some videos you may like

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

jolivanes

Well-known Member
Joined
Sep 5, 2004
Messages
1,660
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
You could try this
Code:
Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Set sh1 = Worksheets("Sheet1")    '<-----Sheet with all the data. Change as required
    For Each c In sh1.Range("H2:H5")
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(sh1.Cells(i, 1), c) > 0 Then Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
        Next i
    Next c
End Sub
 

jolivanes

Well-known Member
Joined
Sep 5, 2004
Messages
1,660
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
If you spruce it up a little bit, you'll get something like this:
Code:
Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")    '<-----Sheet with all the data. Change as required
    For Each c In sh1.Range("H2:H" & sh1.Cells(Rows.Count, 8).End(xlUp).Row)
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(sh1.Cells(i, 1), c) > 0 Then Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
        Next i
    Next c
Sheets("Sheet1").Select    '<-----Sheet with all the data. Change as required
Application.ScreenUpdating = True
End Sub
 

jholly1984

New Member
Joined
Sep 29, 2020
Messages
11
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
Thank you sooooo much! Your code is working BEAUTIFULLY!

Thinking longer term I decided to move the filters off of the data tab to their own tab - as that list grows I think it'll be more manageable that way (I changed your initial code - I haven't tried the new one you just posted yet - but I will!

Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Set sh1 = Worksheets("Data") '<-----Sheet with all the data. Change as required
Set sh2 = Worksheets("Filters")
For Each c In sh2.Range("A2:A5")
If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
If InStr(sh1.Cells(i, 1), c) > 0 Then Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
Next i
Next c
End Sub


One quick (hopefully :) follow-up question: How would I have it carry over the column headers onto the new sheets?

Thank you again for the help!
 

jholly1984

New Member
Joined
Sep 29, 2020
Messages
11
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

If you spruce it up a little bit, you'll get something like this:
Code:
Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")    '<-----Sheet with all the data. Change as required
    For Each c In sh1.Range("H2:H" & sh1.Cells(Rows.Count, 8).End(xlUp).Row)
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(sh1.Cells(i, 1), c) > 0 Then Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
        Next i
    Next c
Sheets("Sheet1").Select    '<-----Sheet with all the data. Change as required
Application.ScreenUpdating = True
End Sub


Thanks for this as well... I'm fairly new to VBA and learning... What does the sprucing up change in the way that the function works (or the results)?
 

jolivanes

Well-known Member
Joined
Sep 5, 2004
Messages
1,660
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
They're both the same. No change in the final result.
The 2nd one returns to the original sheet at the end and has "ScreenUpdating" False and True added to avoid screen flickering.

This should also give you the headers.

Code:
Sub Maybe()
Dim c As Range, i As Long, sh1 As Worksheet
Application.ScreenUpdating = False
Set sh1 = Worksheets("Sheet1")    '<-----Sheet with all the data. Change as required
    For Each c In sh1.Range("H2:H5")
    If Not [ISREF(c.Value!A1)] Then Sheets.Add(, Sheets(Sheets.Count)).Name = c.Value
        For i = 2 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(sh1.Cells(i, 1), c) > 0 Then
                With Sheets(c.Value)
                    .Cells(1, 1).Resize(, 6).Value = sh1.Cells(1, 1).Resize(, 7).Value
                    .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = sh1.Cells(i, 1).Resize(, 6).Value
                End With
            End If
        Next i
    Next c
Sheets("Sheet1").Select    '<-----Sheet with all the data. Change as required
Application.ScreenUpdating = True
End Sub
 

jholly1984

New Member
Joined
Sep 29, 2020
Messages
11
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

Thank you so much for helping with this and helping so quickly. This is truly a game changing macro for the kind of work we do. You are the best!
 

jolivanes

Well-known Member
Joined
Sep 5, 2004
Messages
1,660
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
Thank you for the kind words and for letting us know that all is as wanted.
Good Luck
 

jolivanes

Well-known Member
Joined
Sep 5, 2004
Messages
1,660
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
I neglected to update a couple lines.
Change this
Code:
For Each c In sh1.Range("H2:H5")
to this
Code:
For Each c In sh1.Range("H2:H" & Cells(Rows.Count, 8).End(xlUp).Row)
to be more dynamic in that Column
and this
Code:
Sheets("Sheet1").Select
to this
Code:
sh1.Select
Since we set sh1 to that Sheet1.
Sorry about that.
 

jholly1984

New Member
Joined
Sep 29, 2020
Messages
11
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
No problem at all. Thank you again for the continued support.

One new item that popped up while we have been testing this and realizing its power....is the ability to also count up the actual instances of each modifier as a summary tab.

So if the list is:

Headphones
Laptops
Etc

It would be great to be able to run a separate first pass macros that analyzes the data and counts the instances of each. Is that easy to do?

Output would be something like this: I am using an online text analyzer tool to do this for me now (which produced what you see below)... but maybe excel is better to handle it.

excel2.JPG
 

Watch MrExcel Video

Forum statistics

Threads
1,114,612
Messages
5,548,993
Members
410,887
Latest member
sjohn627
Top