Copy Entire row when one cell equals something

[TangleRidge]

hey guys....I am very new to programming in Excel.

Here is the scoop...I have lots of data results that I need to organize monthly. I need a Macro or VBA so when a cell says something it copies the whole row over to a new sheet.

Here is the kicker. I have 54 separate sheets based on 54 different cell criteria that the rows need to be copied into. I am able to write a VBA to do one but can't figure out how to make multiple copies to a new sheet..Can anyone help me out?

eg) If cell D2 under brand says X, the whole row needs to move to sheet X. There are 54 different brands so 54 different sheets.

ID	Report Date	Modified Date	Brand	Category

<colgroup><col><col span="2"><col><col></colgroup><tbody>
</tbody>

 

[TangleRidge]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

This is the VBA I am currently using.i can't figure out how to make it work mulitple times. It only works once. I understand I have to fill out the criteria each time (54 to be exact) but how do I make it work?

Sub Test()

For Each Cell In Sheets(1).Range("F:F")
If Cell.Value = "X" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy

Sheets("X").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select


End If
Next
End Sub

 

[My Aswer Is This]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

I'm assuming you want to copy each row in the active sheet to the sheet identified in column F of the active sheet.

So stating in row(2) if column F has One then copy this row to a sheet named One
And if row(3) column F has Two then you want to copy this row to a sheet named Two

And on and on.
And I'm assuming the sheets have already been created.

Then try this:

Run this script from the active sheet with all your data:

Sub Copy_Rows_To_Colunmnf_Sheet_Name()
'Modified 8/27/2018 10:40 PM  EDT
Application.ScreenUpdating = False
On Error GoTo M
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "F").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Cells(Rows.Count, "F").End(xlUp).Row
    For i = 2 To Lastrow
        Lastrowa = Sheets(Cells(i, "F").Value).Cells(Rows.Count, "F").End(xlUp).Row + 1
        Rows(i).Copy Sheets(Cells(i, "F").Value).Rows(Lastrowa)
    Next
Application.ScreenUpdating = True
Exit Sub
M:  MsgBox "You have no sheet named" & vbNewLine & Cells(i, "F").Value
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

Or use this script using filter.
We are assuming we have a Master sheet and in column F are the sheet names.
And all sheets already exist:

Run this script from the Master sheet:

Sub Filter_Me_Please()
'Modified  8/27/2018  11:45:10 PM  EDT
Application.ScreenUpdating = False
Dim Lastrow As Long
Dim c As Long
Dim i As Long
Dim ans As String
c = "6" ' Column Number Modify this to your need
Lastrow = Cells(Rows.Count, c).End(xlUp).Row
For i = 2 To Sheets.Count
With ActiveSheet.Cells(1, c).Resize(Lastrow)
    .AutoFilter 1, Sheets(i).Name
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
    ans = Sheets(i).Name
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(ans).Cells(1, 1)
    Else
        MsgBox "No values found for sheet named " & Sheets(i).Name
    End If
    .AutoFilter
    
End With
Next
Application.ScreenUpdating = True
End Sub

 

[vcoolio]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

Hello TangleRidge,

You could also use a Worksheet_Change event code as follows:-

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Columns(6)) Is Nothing Then Exit Sub  '---->The criteria is in Column F (6).
If Target.Count > 1 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub

Target.EntireRow.Copy Sheets(Target.Value).Range("A" & Rows.Count).End(3)(2)

End Sub

This is a button-less method which means that once you enter a value in a cell in Column F, then move on to the next cell to enter data, the relevant entire row of data will be transferred to its respective sheet. The code assumes that all sheets already exist.

To implement this code:-

- Right click on the main sheet tab.
- Select "View Code" from the menu that appears.
- In the big white field that then appears, paste the above code.
- Save your workbook with the .xlsm file extension.

Test the code in a copy of your workbook first.

I hope that this helps.

Cheerio,
vcoolio.

P.S. Should Column F actually be Column D as per your opening post? Your code in post #2 shows Column F as the criteria column.
Do you need the "used" row of data in the main sheet deleted once each transfer is completed?

 

[TangleRidge]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

Thanks Guys, I will give these a try...

Basically I do a data dump into a Master Sheet template. When I data dump into the Master Sheet I would like it to use the indicator in Column F and automatically transfer the row data to the corresponding sheets that already exist.

 

[My Aswer Is This]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

Then you need to use my script in Post #4
A sheet change event that runs automatically I do not believe will work when you have a large data dump
But clicking a button or using a shortcut key to activate my script I would not think would be a problem.

 

[TangleRidge]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

Thanks. I ran the script and it just says no values are found. It goes through all my sheets and says no data is found for each one. But there is data in the Master sheet...I think we are close...Just need it to move the data in each row to the corresponding sheet.

 

[TangleRidge]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

Ok. I figured out my issue. The sheet names don't match the criteria in F exactly. Is there a way to update the script so that the criteria doesn't have to match sheet names exactly but at least partially?

 

[My Aswer Is This]

Re: Help!! Copy Entire row when one cell equals something...Lots of Data

Try this:

Sub Filter_Me_Please()
'Modified  8/28/2018  4:05:09 PM  EDT
Application.ScreenUpdating = False
Dim Lastrow As Long
Dim c As Long
Dim i As Long
Dim ans As String
c = "6" ' Column Number Modify this to your need
Lastrow = Cells(Rows.Count, c).End(xlUp).Row
For i = 2 To Sheets.Count
With ActiveSheet.Cells(1, c).Resize(Lastrow)
    .AutoFilter 1, "*" & Sheets(i).Name & "*"
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then
    ans = Sheets(i).Name
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(ans).Cells(1, 1)
    Else
        MsgBox "No values found for sheet named " & Sheets(i).Name
    End If
    .AutoFilter
    
End With
Next
Application.ScreenUpdating = True
End Sub