Thread: Copy rows from 1 sheet by Group

'SHEET1 TO MANY SHEETS
I have a macro that may be "ready to use" for parsing rows of data from one sheet to many sheets named for the same values.

Sheet1 to Many Sheets

It not only can parse the rows, it can create the sheets if they are missing.

I've edited the macro and inserted it into your workbook. I've adjusted your sheet1 so it's simpler to evaluate. Press Alt-F8 and run the macro.

If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.

Err.. Hi again. I had a doubt again with this.

MyArr is declared as a Variant. But in the sheet, if MyArr holds only 1 value(A Range Object), and I loop through it using:

For Itm = 1 To UBound(MyArr)
'or
For Itm = LBound(MyArr) To UBound(MyArr)

it is giving a type mismatch. Please suggest where am I going wrong here...

Post your misbehaving workbook and we can look at it together.

I do not experience any errors with the code given on the sample workbook. If you've changed the values in some way and are now experiencing an error, I need to see that.

If I were to just guess, I'd say it should work with any number of values.

I added an entry to the sample sheet that was a single entry and it worked.

All I have to go on is the sample sheet and your questions. I can't duplicate the problem you're having. Upload a sample sheet that actually is misbehaving and I'm sure I can help quickly, so far I can't.

The light's just came on..took me a while. Try this:

Option Explicit

Sub ParseItems()
'Author:    Jerry Beaucaire
'Original Date:    11/11/2009
'Summary:    Based on selected column, data is filtered to individual sheets
'        Creates sheets and sorts sheets alphabetically in workbook
'        6/10/2010 - added check to abort if only one value in vCol
'        7/22/2000 - added ability to parse numeric values consistently
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, Oops As Boolean

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 27
 
'Sheet with data in it
   Set ws = Sheets("Sheet2")

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:AA1"
   
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

'Add key formula in empty column
    ws.Range("AA1") = "Key"
    With ws.Range("AA2:AA" & LR)
        .FormulaR1C1 = "=VLOOKUP(RC1, Sheet1!C1:C2, 2, 0)"
        .Value = .Value
    End With

'Get a temporary list of unique values from column A
      ws.Range("AA:AA").SpecialCells(xlConstants).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

'Put list into an array for looping
'(values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE1:EE" _
        & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
'In case values are numerical, we convert them to text with ""
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""
    
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm) & ""
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm) & "").Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(Itm) & "").Cells.Clear
        End If
    
        ws.Range("A" & Range(vTitles).Resize(1, 1) _
            .Row & ":C" & LR).Copy Sheets(MyArr(Itm) & "").Range("A1")
        
        ws.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr(Itm) & "") _
            .Range("A" & Rows.Count).End(xlUp).Row - 1
        Sheets(MyArr(Itm) & "").Columns.AutoFit
    Next Itm
    
'Cleanup
    ws.AutoFilterMode = False
    ws.Range("AA:AA").Clear
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"

Application.ScreenUpdating = True
End Sub

In post #11 I changed the macro to always include the header in the array resolution, so when only one value is in the list, it still has two item, the header and that one item. Then I always start the loop later with the second item in the array which is one real item.

It should be working now, I was able to duplicate your problem and post #11 shows how I resolved it.

If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.