PDA

View Full Version : Copying rows over to new workbooks based on unique column values



RathB
10-19-2017, 03:15 AM
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
10-19-2017, 04:39 AM
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
10-19-2017, 04:55 AM
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
10-19-2017, 05:20 AM
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
10-19-2017, 05:56 AM
The correct code for that line is:


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

sorry about that , I was guessing

RathB
10-19-2017, 08:24 AM
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