Sending a moving range of cells to different people

[Saschah]

Hey Guys,

Okay this is going to be difficult to explain...

First let me explain what I am trying to do.

I have made a big planning with 46 different people in. They all have their collum. (dates are on the rows)
They all need to get their piece of the planning.

That for the easy part..

The planning grows each week,
The days in the past remain in the planning while every week I add new weeks...
Each person needs to get their planning for the next 3 months.

So i'll try to set up an example:

We have a person C, D, F and G, named after their collums. (G's planning has multiple collums)

This week they need to get their planning as in:

C needs: Cell C5:C50
D needs: Cell D5:D50
F needs: Cell F5:F50
G needs: Cell G5:I50

Next week they need to get this planning:
C needs: Cell C10:C55
D needs: Cell D10:D55
F needs: Cell F10:F55
G needs: Cell G10:I55


So i think the moving part is the most difficult?

I have worked something out with different tabs per person but when i move stuff around it doesn't always changes which kind of makes my planning useless...

Could you guys/girls help me out?
If I didn't explained it clear enough, just let me know.

Thanks!!

 

[FormR]

if you re-create it in a new workbook and use the code in post#7 do you get the results you would expect?

Hi, maybe you could try this and see if we are heading in the right direction before we start adapting it to your actual set-up?

 

[Saschah]

Hi, maybe you could try this and see if we are heading in the right direction before we start adapting it to your actual set-up?

Hey FormR,

So, it worked like I wanted it to. Great!!

But now when I try it on my table it gives me an error on the .Autofilter part

 

[FormR]

But now when I try it on my table it gives me an error on the .Autofilter part

Hi, it's probably because your actual layout is not as you originally described.

Give this version a try, if you get any errors let us know the error text (in English) and which line is highlighted when you click "debug".

Sub M1()
Dim i As Long, oldPrintA As String, dStart As Long, dEnd As Long, lr As Long, lc As Long
Const sFolder As String = "C:\Temp" 'Change folder path here
dStart = Date
dEnd = DateAdd("WW", 10, dStart) '10 = number of weeks
lc = Cells(1, Columns.Count).End(xlToLeft).Column
lr = Columns("A").Resize(lc).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
With Range("A1").Resize(lr, lc)
    oldPrintA = .Parent.PageSetup.PrintArea
    For i = 4 To .Columns.Count
        .AutoFilter
        .AutoFilter Field:=3, Criteria1:=">=" & dStart, Operator:=xlAnd, Criteria2:="<=" & dEnd
        .AutoFilter Field:=i, Criteria1:="<>"
        .Parent.PageSetup.PrintArea = .Resize(, i).Address
        .Parent.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolder & "\" & Cells(1, i).Value & ".PDF", OpenAfterPublish:=False
        .Columns(i).Hidden = True
    Next i
    .Parent.PageSetup.PrintArea = oldPrintA
    .Columns.Hidden = False
    .AutoFilter
End With
End Sub

 

[Saschah]

Hi, it's probably because your actual layout is not as you originally described.

Give this version a try, if you get any errors let us know the error text (in English) and which line is highlighted when you click "debug".

Sub M1()
Dim i As Long, oldPrintA As String, dStart As Long, dEnd As Long, lr As Long, lc As Long
Const sFolder As String = "C:\Temp" 'Change folder path here
dStart = Date
dEnd = DateAdd("WW", 10, dStart) '10 = number of weeks
lc = Cells(1, Columns.Count).End(xlToLeft).Column
lr = Columns("A").Resize(lc).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
With Range("A1").Resize(lr, lc)
    oldPrintA = .Parent.PageSetup.PrintArea
    For i = 4 To .Columns.Count
        .AutoFilter
        .AutoFilter Field:=3, Criteria1:=">=" & dStart, Operator:=xlAnd, Criteria2:="<=" & dEnd
        .AutoFilter Field:=i, Criteria1:="<>"
        .Parent.PageSetup.PrintArea = .Resize(, i).Address
        .Parent.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolder & "\" & Cells(1, i).Value & ".PDF", OpenAfterPublish:=False
        .Columns(i).Hidden = True
    Next i
    .Parent.PageSetup.PrintArea = oldPrintA
    .Columns.Hidden = False
    .AutoFilter
End With
End Sub

Okay,

I tried the new version but I get the same as before:

The first .AutoFilter is Highlighted. and is the error is: Error 1004 during ?process?: Method AutoFilter of ?class? Range has failed

 

[FormR]

Hmm, not sure - it works for me. If you copy the sample data that you posted here into a new workbook does it then work?

 

[Saschah]

Hmm, not sure - it works for me. If you copy the sample data that you posted here into a new workbook does it then work?

Could the problem be that I have it set up as a table?

 

[FormR]

Could the problem be that I have it set up as a table?

I don't think so, but it does simplify (things if we can get it working) : is it the only table on the sheet?

Sub M1()
Dim i As Long, oldPrintA As String, dStart As Long, dEnd As Long
Const sFolder As String = "H:\Temp" 'Change folder path here
dStart = Date
dEnd = DateAdd("WW", 10, dStart) '10 = number of weeks
With ActiveSheet.ListObjects(1).Range
    oldPrintA = .Parent.PageSetup.PrintArea
    For i = 4 To .Columns.Count
        .AutoFilter
        .AutoFilter Field:=3, Criteria1:=">=" & dStart, Operator:=xlAnd, Criteria2:="<=" & dEnd
        .AutoFilter Field:=i, Criteria1:="<>"
        .Parent.PageSetup.PrintArea = .Resize(, i).Address
        .Parent.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolder & "\" & Cells(1, i).Value & ".PDF", OpenAfterPublish:=False
        .Columns(i).Hidden = True
    Next i
    .Parent.PageSetup.PrintArea = oldPrintA
    .Columns.Hidden = False
    .AutoFilter
End With
End Sub

If this doesn't work can you upload a sanitised version of the workbook to a file sharing site, like dropbox for example, and share the link here.

 

[FormR]

Hopefully using the listobject will solve it, but I spotted the typo in the code in post#13:

This line:

lr = Columns("A").Resize(lc).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

Should be:

lr = Columns("A").Resize(,lc).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

 

[Saschah]

Hopefully using the listobject will solve it, but I spotted the typo in the code in post#13:

This line:

lr = Columns("A").Resize(lc).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

Should be:

lr = Columns("A").Resize(,lc).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

It worked!
It took a while to make al the .PDF but it worked!

Now i'll try to add the part to automaticly mail the .PDF to the right person.

Thanks for all the help!!!

 

[FormR]

It worked

Phew! Good luck with the rest of the project