Ophi
03-24-2017, 09:05 AM
I have a macro which is supposed to review the data in one workbook and then create several workbooks including the title row from the original workbook and the rows for each change in data in a certain column. So, for example, workbook one would create with the title rows and lines 2-10 and then workbook two would create with the title rows and lines 11-152, and so on, based on the fact that the break point / change in data to which it refers comes at lines 2 and 11 respectively.
This macro was created after much searching and with help, (including from this forum), but when I go to test it now I find that it is creating the workbooks and includes the title row but does not paste the data from the rows.
Would be grateful for advice.
Sub splitCUbycolumn() Dim wb As Workbook, sh As Worksheet, ssh As Worksheet, lr As Long, rng As Range, c As Range, lc As Long
Set sh = Sheets(1)
lr = sh.Cells(Rows.Count, "M").End(xlUp).Row
lc = sh.Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious).Column
sh.Range("A" & lr + 2).CurrentRegion.Clear
sh.Range("M1:M" & lr).AdvancedFilter xlFilterCopy, , sh.Range("A" & lr + 2), True
Set rng = sh.Range("A" & lr + 3, sh.Cells(Rows.Count, 1).End(xlUp))
For Each c In rng
Set wb = Workbooks.Add
Set ssh = wb.Sheets(1)
ssh.Name = c.Value
sh.Range("A1", sh.Cells(lr, lc)).AutoFilter 12, c.Value
sh.Range("A1", sh.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).Copy ssh.Range("A1")
sh.AutoFilterMode = False
wb.SaveAs ThisWorkbook.Path & "\Created Files\" & c.Value & ".xlsx"
wb.Close False
Set wb = Nothing
Next
sh.Range("A" & lr + 2, sh.Cells(Rows.Count, 1).End(xlUp)).Delete
End Sub
This macro was created after much searching and with help, (including from this forum), but when I go to test it now I find that it is creating the workbooks and includes the title row but does not paste the data from the rows.
Would be grateful for advice.
Sub splitCUbycolumn() Dim wb As Workbook, sh As Worksheet, ssh As Worksheet, lr As Long, rng As Range, c As Range, lc As Long
Set sh = Sheets(1)
lr = sh.Cells(Rows.Count, "M").End(xlUp).Row
lc = sh.Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious).Column
sh.Range("A" & lr + 2).CurrentRegion.Clear
sh.Range("M1:M" & lr).AdvancedFilter xlFilterCopy, , sh.Range("A" & lr + 2), True
Set rng = sh.Range("A" & lr + 3, sh.Cells(Rows.Count, 1).End(xlUp))
For Each c In rng
Set wb = Workbooks.Add
Set ssh = wb.Sheets(1)
ssh.Name = c.Value
sh.Range("A1", sh.Cells(lr, lc)).AutoFilter 12, c.Value
sh.Range("A1", sh.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).Copy ssh.Range("A1")
sh.AutoFilterMode = False
wb.SaveAs ThisWorkbook.Path & "\Created Files\" & c.Value & ".xlsx"
wb.Close False
Set wb = Nothing
Next
sh.Range("A" & lr + 2, sh.Cells(Rows.Count, 1).End(xlUp)).Delete
End Sub