Vba/Macro Search Rows for value and copy/paste accordingly

Hello,

I am helping to manage ad inventory/ordering/small emails for a local home operation.
What im trying to do is take the data from the colored tabs and put it into the appropriate spot on the normal grey tabs by vegetable or fruit. Currently we filter the sheet then copy and paste the data. This becomes a headache when tracking 100s of veggies/fruits/flowers. Is there a way for a macro or vba to reference a list, filter for it, and then copy and paste the data in the correct tab? I already manually did this for Cabbage. Our sheets can turn into a couple hundred fruits/veggies/flowers in one month, so you can imagine how manually painful this becomes. Any sheet modifications or suggestions are warmly welcome.

This appears to be a duplicate Thread.

http://www.excelforum.com/excel-prog...ml#post3482630

Please ask a Moderator to remove the Duplicate.

Then answer these questions:

Will these Reports be generated once a month or periodically throughout the Month?

If periodically, will the reports be recreated or only new records processed?

If only new records,will the first three sheets contain only new records or will the old processed records still be there?

Hi Aquabat

This Code is in the attached and appears to do as you require...let me know of issues...keyboard shortcut...CTRL + x

Option Explicit

Sub Create_Reports()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim cel As Range
    Dim LR As Long
    Dim vWs As Variant

    Set ws1 = Sheets("Store Ad Display")
    Set ws2 = Sheets("Core Products")
    Set ws3 = Sheets("Email to Locals")

    Application.ScreenUpdating = False
    If Not Evaluate("ISREF(Lists!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
    Else
        Sheets("Lists").Cells.Clear
    End If

    With ws1
        LR = .Range("C" & .Rows.Count).End(xlUp).Row

        .Range("C2:C" & LR).AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Sheets("Lists").Range("A1"), Unique:=True

        ActiveWorkbook.Names.Add Name:="Products", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
    End With

    For Each cel In Range("Products")
        For Each vWs In Array(ws1, ws2, ws3)
            With vWs
                Select Case vWs.Name
                Case ws1.Name
                    With ws1
                        If Not .AutoFilterMode Then
                            .Range("A2").AutoFilter
                            .Range(("A2"), .Range("A2").End(xlDown)).AutoFilter Field:=3, Criteria1:=cel.Value & "*"

                            If Not Evaluate("ISREF('" & cel.Value & " Store Ad" & "'!A1)") Then
                                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cel.Value & " Store Ad"
                            Else
                                Sheets(cel.Value & " Store Ad").Cells.Clear
                            End If
                            .AutoFilter.Range.Copy

                            With Sheets(cel.Value & " Store Ad")
                                .Range("A2").PasteSpecial Paste:=8
                                .Range("A2").PasteSpecial
                                .Range("A1").Value = "Store Ad"
                            End With

                            .AutoFilterMode = False
                        End If
                    End With
                Case ws2.Name
                    With ws2
                        If Not .AutoFilterMode Then
                            .Range("A2").AutoFilter
                            .Range(("A2"), .Range("A2").End(xlDown)).AutoFilter Field:=4, Criteria1:=cel.Value & "*"

                            If Not Evaluate("ISREF('" & cel.Value & " Core products" & "'!A1)") Then
                                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cel.Value & " Core products"
                            Else
                                Sheets(cel.Value & " Core products").Cells.Clear
                            End If

                            .AutoFilter.Range.Copy

                            With Sheets(cel.Value & " Core products")
                                .Range("A2").PasteSpecial Paste:=8
                                .Range("A2").PasteSpecial
                                .Range("A1").Value = "Core products"
                            End With

                            .AutoFilterMode = False
                        End If
                    End With
                Case ws3.Name
                    With ws3
                        If Not .AutoFilterMode Then
                            .Range("A2").AutoFilter
                            .Range(("A2"), .Range("A2").End(xlDown)).AutoFilter Field:=7, Criteria1:=cel.Value & "*"

                            If Not Evaluate("ISREF('" & cel.Value & " Email to Locals" & "'!A1)") Then
                                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cel.Value & " Email to Locals"
                            Else
                                Sheets(cel.Value & " Email to Locals").Cells.Clear
                            End If

                            .AutoFilter.Range.Copy

                            With Sheets(cel.Value & " Email to Locals")
                                .Range("A2").PasteSpecial Paste:=8
                                .Range("A2").PasteSpecial
                                .Range("A1").Value = "Email to Locals"
                            End With

                            .AutoFilterMode = False
                        End If
                    End With

                End Select
            End With
        Next vWs
    Next cel
    Application.DisplayAlerts = False
    Sheets("Lists").Delete
    Application.DisplayAlerts = True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Hi Aquabat

Firstly...What is the Error Message?

Secondly...Hover over Cel.Value to see what it evaluates to...I suspect it evaluates to Empty or Blank ("") and this may be the source of the problem.

Thirdly...What's your alternative Sheet Naming Convention? As long as your Sheet Naming Convention in the "large list" is the same as in your Sample File, there's no need to rename them.

All else fails, upload the "large list" so I can debug the issue.

Hi Aquabat

I suspect it has to do with the blank space in "White Roses". I thought I had that handled but if that's the source of the issue, obviously not.

Two alternatives:

1. Revise your Sample File to include the "White Roses" records and upload the revised Sample File.
2. Upload the "large list" File.

Either way, I'll look at it.

Please attach a sample file that represents what you have. The structure of your attachment should be the same structure as your actual data. Any proprietary information should be changed.

Include in the attachment any code you're currently using (whether it works or not) and an "After" worksheet that demonstrates what you wish the output to be.

To Attach a File:

1. Click on Go Advanced
2. In the frame Attach Files you will see the button Manage Attachments
3. Click the button.
4. A new window will open titled Manage Attachments - Excel Forum.
5. Click the "Add Files"... button to locate your file for uploading.
6. This will open a new window File Upload...Click "Select Files"
7. Once you have located the file to upload click the Open button. This window will close.
8. You are now back in the Manage Attachments - Excel Forum window.
9. Click the "Upload Files" button and wait until the file has uploaded.
10. Click the "Done" Button.

Hi Aquabat

There were two issues, both dealing with Naming the new Worksheets;

1. Worksheets containing more than 32 Characters, for example "Red Large Poinsettias Core Products". I resolved this by contracting the Sheet Name to "Red Large Poinsettias CP".

2. Code does not like the apostrophe in a Sheet Name. When using Code the apostrophe is a Special Character used to delineate a Sheet Name with Spaces in the Name such as "America's Best". So, this line of Code

 If Not Evaluate("ISREF('" & cel.Value & " SA" & "'!A1)") Then

will error when it looks for a Sheet Named "America's Best" because it interprets the included Apostrophe as a Special Character. See the discussion here

http://support.microsoft.com/kb/107468

The Code in the attached has been modified to handle these exceptions. Let me know of issues.

You're welcome...glad I could help. Thanks for the Rep.