Hello,
I have the following code set up to break up a single workbook into multiple workbooks for a distribution process. The code works great (thanks to those on this forum who helped me get it together a few years ago!), but with the advanced filter function, it's pasting only values, not formulas. I'd like to retain any relevant formulas when breaking up workbooks. Would anyone know how I could embed that into this code?
Thanks in advance!
Sub DistributeRows()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
Set wsData = Worksheets("FileDistribution")
Set wsCrit = Worksheets.Add
LastRow = wsData.Range("BI" & Rows.Count).End(xlUp).Row
wsData.Range("BI1:BI" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
Set rngCrit = wsCrit.Range("A2")
While rngCrit.Value <> ""
Set wsNew = Worksheets.Add
wsData.Range("A1:BZ" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
wsNew.Name = rngCrit
Columns("A:BZ").AutoFit
Range("A1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
ActiveSheet.PageSetup.PrintArea = ""
wsNew.Copy
Set wbNew = ActiveWorkbook
wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
wbNew.Close SaveChanges:=True
Application.DisplayAlerts = False
wsNew.Delete
rngCrit.EntireRow.Delete
Set rngCrit = wsCrit.Range("A2")
Wend
wsCrit.Delete
Application.DisplayAlerts = True
End Sub
I have the following code set up to break up a single workbook into multiple workbooks for a distribution process. The code works great (thanks to those on this forum who helped me get it together a few years ago!), but with the advanced filter function, it's pasting only values, not formulas. I'd like to retain any relevant formulas when breaking up workbooks. Would anyone know how I could embed that into this code?
Thanks in advance!
Sub DistributeRows()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
Set wsData = Worksheets("FileDistribution")
Set wsCrit = Worksheets.Add
LastRow = wsData.Range("BI" & Rows.Count).End(xlUp).Row
wsData.Range("BI1:BI" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
Set rngCrit = wsCrit.Range("A2")
While rngCrit.Value <> ""
Set wsNew = Worksheets.Add
wsData.Range("A1:BZ" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
wsNew.Name = rngCrit
Columns("A:BZ").AutoFit
Range("A1").Select
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With
ActiveSheet.PageSetup.PrintArea = ""
wsNew.Copy
Set wbNew = ActiveWorkbook
wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
wbNew.Close SaveChanges:=True
Application.DisplayAlerts = False
wsNew.Delete
rngCrit.EntireRow.Delete
Set rngCrit = wsCrit.Range("A2")
Wend
wsCrit.Delete
Application.DisplayAlerts = True
End Sub