Copying rows over to new workbooks based on unique column values

[RathB]

Hi all

I have a spreadsheet with column E having duplicate values. The row headers are in row 3. I'd like to split the sheet for each unique value in column E and its associated rows, where they're copied over to different workbooks - one workbook per unique value from column E, populated with all the rows for the duplicates of that value in the original spreadsheet.

I've been using the code below based on something I found, however it doesn't seem to work. I get the error "Run-time error '1004': No cells were found." I've highlighted the code in red below where the debugger states the error is. Can someone please help me troubleshoot the code? Alternatively, I'm happy to get other suggestions for working code

Option Explicit

Sub ParseItems()
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

'Sheet with data in it
   Set ws = Sheets("Sheet1")

'Path to save files into, remember the final \
    SvPath = "C:\My Work Documents\"

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A3:E3"
   
'Choose column to evaluate from, column A = 1, B = 2, etc.
   vCol = 5

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    ws.Columns(vCol).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("EE2: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
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
        
        ws.Range("A1:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
        
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal
        'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51   'use for Excel 2007+
        ActiveWorkbook.Close False
        
        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = True
End Sub

[offthelip]

I would do by using variant arrays which is much faster than using filters and copy and paste.

untested but something like this:

Sub ParseItems()     'Based on selected column, data is filtered to individual workbooks
     'workbooks are named for the value plus today's date
    Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
    Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
     Dim temparr() As Variant
     
     'Sheet with data in it
    Set ws = Sheets("Sheet1")
     
     'Path to save files into, remember the final \
    SvPath = "C:\My Work Documents\"
     
     'Range where titles are across top of data, as string, data MUST
     'have titles in this row, edit to suit your titles locale
    vTitles = "A3:E3"
     
     'Choose column to evaluate from, column A = 1, B = 2, etc.
    vCol = 5
     
     'Spot bottom row of data
    LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
    lc = ws.Cells(ws.Cols.Count, 3).End(xlLeft).Col
     
     'Speed up macro execution
    Application.ScreenUpdating = False
     
     'Get a temporary list of unique values from key column
    Set myrange = Range(Cells(3, 1), Cells(LR, lc))
    Set Sortkey = Range(Cells(3, vCol), Cells(LR, vCol))
    myrange.Sort key1:=Sortkey, order1:=xlAscending, MatchCase:=False, Header:=xlYes


     
     
     'Put list into an array for looping (values cannot be the result of formulas, must be constants)
   MyArr = Range(Cells(3, 1), Cells(LR, lc))
   For i = 1 To LR - 2
' Find where the key column changes
       For j = i To LR - 3
        If MyArr(j, vCol) <> MyArr(j + 1, vCol) Then
        ' found next block
          endj = j - i
          Exit For
        End If
       Next j
       ' Now copy the block of identical items to a new sheet
        ReDim temparr(1 To endj, 1 To lc)
        For jj = 1 To endj
         For k = 1 To lc
         temparr(jj, k) = MyArr(jj + i, k)
         Next k
        Next jj
        
        Itm = MyArr(j, vCol)
        Workbooks.Add
        Range(Cells(1, 1), Cells(endj, lc)) = temparr
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY"), xlNormal
         'ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & Format(Date, " MM-DD-YY") & ".xlsx", 51   'use for Excel 2007+
        ActiveWorkbook.Close False
         
       
    Next i
     
     'Cleanup
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = True
End Sub

[RathB]

Thanks offthelip - unfortunately seems I'm getting a compile error?

Following gets highlighted (specifically 'Cols'):

lc = ws.Cells(ws.Cols.Count, 3).End(xlLeft).Col

[mana]

Sub test()
    Dim ws As Worksheet
    Dim rngS As Range, rngC As Range
    Dim MyCount As Long
    Dim SvPath As String
    Dim vCol As Long
    
    SvPath = "C:\My Work Documents\"
   vCol = 5
   
    Set ws = Sheets("Sheet1")
    Set rngS = ws.Range("A3").CurrentRegion.Resize(, vCol)
    Set rngC = ws.Range("EE1")
    
  
    rngS.Columns(vCol).AdvancedFilter xlFilterCopy, , rngC, True


    Do While rngC.Offset(1).Value <> ""
        With Workbooks.Add.Sheets(1)
             rngS.AdvancedFilter xlFilterCopy, rngC.Resize(2), .Range("A1")
             .Columns("A:E").AutoFit
             MyCount = MyCount + .Range("A1").CurrentRegion.Rows.Count - 1
             .Parent.SaveAs SvPath & rngC.Offset(1).Value & Format(Date, " MM-DD-YY"), xlNormal
             .Parent.Close False
         End With
         rngC.Offset(1).Delete xlShiftUp
    Loop
    rngC.Clear
    
    MsgBox "Rows with data: " & rngS.Rows.Count - 1 & vbLf _
        & "Rows copied to other sheets: " & MyCount & vbLf _
        & "Hope they match!!"
        
End Sub

マナ

[offthelip]

The correct code for that line is:

lc = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column

sorry about that , I was guessing

[RathB]

Mana thanks for that! It seemed to do the trick. I had to do some tweaking based on the spreadsheet I used as follows, but now works a charm!

Sub split()


    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim rngS As Range, rngC As Range, rngH As Range
    Dim MyCount As Long
    Dim SvPath As String
    Dim vCol As Long
     
    SvPath = "C:\My Work Documents\"
    vCol = 5
     
    Set ws = Sheets("CONDENSED")
    row_no = Application.CountA(ws.Range("A:A")) + 2
    Set rngS = ws.Range("A3:AG" & row_no)
    Set rngC = ws.Range("EE1")
    Set rngH = ws.Range("A1:AG2")
     
    rngS.Columns(vCol).AdvancedFilter xlFilterCopy, , rngC, True
     
    Do While rngC.Offset(1).Value <> ""
        With Workbooks.Add.Sheets(1)
            rngH.Copy Destination:=.Range("A1")
            rngS.AdvancedFilter xlFilterCopy, rngC.Resize(2), .Range("A3")
            .Columns("A:AG").AutoFit
            MyCount = MyCount + .Range("A3").CurrentRegion.Rows.Count - 1
            Application.DisplayAlerts = False
            .Parent.SaveAs SvPath & rngC.Offset(1).Value & Format(Date, " DD-MM-YY"), xlNormal
            .Parent.Close False
            Application.DisplayAlerts = True
        End With
        rngC.Offset(1).Delete xlShiftUp
    Loop
    rngC.clear
    
    Application.ScreenUpdating = True
     
    MsgBox "Rows with data: " & rngS.Rows.Count - 1 & vbLf _
    & "Rows copied to other sheets: " & MyCount & vbLf _
    & "Time to send on to advisors!"
     
End Sub