Code pasting values, not formulas

[ollieotis]

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

 

[Snakehips]

ollieotis,

This is not tested!!

But try replacing your first filter/copy/paste...

wsData.Range("BI1:BI" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True

with .....

wsData.Range("BI1:BI" & LastRow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
wsCrit.Range("A1").PasteSpecial Paste:=xlPasteFormulas

If that does the trick then you can similarly edit your second filter/copy/paste.

Hope that helps.

 

[ollieotis]

Thank you, Tony. I couldn't get that to work though... probably user error, but I keep getting run time errors.

 

[Snakehips]

ollieotis,

My stupid fault!!! Trying to paste without copy!!!

Try.......

wsData.Range("BI1:BI" & LastRow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
wsData.Range("BI1:BI" & LastRow).Copy
wsCrit.Range("A1").PasteSpecial Paste:=xlPasteFormulas

Hopefully that's better.

 

[Marcelo Branco]

Maybe (tested with a very small data sample)

Instead of

wsData.Range("A1:BZ" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True

This

wsData.Range("A1:BZ" & LastRow).AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=rngCrit.Offset(-1).Resize(2), Unique:=True
wsData.Range("A1:BZ" & LastRow).SpecialCells(xlCellTypeVisible).Copy
wsNew.Range("A1").PasteSpecial xlPasteFormulas

M.

 

[ollieotis]

I'm almost certain I'm missing something really obvious, but my three year old who is sitting next to me desperately wants my attention and I'm struggling to focus...

That said, I've tried copying in that code and I can't get it to work. If I copy to just the first set, I get the same results. If I copy the code to both filter sections, the macro runs on the first filename in perpetuity. I have to hit escape to get out.

Thanks!

 

[Marcelo Branco]

I think Snakehip is right - SpecialCells(xlCellTypeVisible) works but it's not necessary

Maybe if you use for the first filter Snakehip's code

wsData.Range("BI1:BI" & LastRow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
wsData.Range("BI1:BI" & LastRow).Copy
wsCrit.Range("A1").PasteSpecial Paste:=xlPasteFormulas

and for the second

wsData.Range("A1:BZ" & LastRow).AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=rngCrit.Offset(-1).Resize(2), Unique:=True
wsData.Range("A1:BZ" & LastRow).Copy
wsNew.Range("A1").PasteSpecial xlPasteFormulas

M.

 

[ollieotis]

Got it working now... Thanks to you both for all the help!!!

 

[Marcelo Branco]

Well done!
You are welcome and thanks for the feedback

M.