Copy autofilter data to (Template) sheet ... error occurs after clearcontents

[timpie_s]

Hello,

I am trying to set up a page which holds the info of all workers that worked on a specific given
date per Team (Painter, Carpenter, ..)
All workers are in a sheet which holds name, start and end date of contract, etc .. And which team they were assigned to.
So far I have come up with a working solution ... the only thing is that it errors out when I try to clear (using clearcontents) the previous run of the macro. (for another date)
It's specifically the clearcontents which leads to the error ... because when I comment it out the code works but then the data might not always be correct if there is less rows of new data is then the old data (old data does not get overwritten)

Can anyone shed a light on why it errors?? I tried debugging but I can't seem to find it. I thought it might have someting to do with losing focus on active cell so I tried activating a cell after "clearcontents" but to no avail.

In a nutshell:
There are 2 Sheets (Trajectory and Ploegen)
The first sheet holds all the workers that worked and still do for us (of course I changed all privacy data)
Second Sheet is the template that needs filling in on a specific date.

Ex. line of Sheet Trajectory:

Tom	Sawyer	1/12/2013	15/2/2014	Painter1
Ellen	Decree	1/5/2013	16/4/2014	Carpenter
Yves	Show	1/5/2013	18/6/2014	Painter2
Mark	Fall	1/8/2014		Builder

<tbody>
</tbody>

Preferred Output = Template which is needed for our personnel manager
Date: 1/2/2014 ==> This Date Is where

Date	1/2/2014
Painter1
Tom	Sawyer	1/12/2013	15/2/2014	...
...
Painter2
Yves	Show	1/5/2013	18/6/2014	...
...
Carpenter
Ellen	Decree	1/5/2013	16/4/2014
Builder
Mark	Fall	1/8/2014

<tbody>
</tbody>

and so on ...

I created a macro attached to the button "Teams" which calls Sub Copytest with a date as argument.

Any help or pointers in the right direction is greatly appreciated. Below is the code

Sub CopyTest(RefDate As Date)
' TODO
' Create FilterRange programmatically R10-> Rendofdate
Dim StartCol, EindCol, REindCol, PloegCol, NameCol, RRCol As String
Dim Ploeg As Variant
Dim PloegData, Rng As Range
Dim Filter As Range
'Dim txtSampleTextBox As MSForms.TextBox


If Not SheetExists("Ploegen") Then
Worksheets.Add After:=Worksheets("Traject")
ActiveSheet.Name = "Ploegen"
Else
'Sheets("Ploegen").UsedRange.Clear
Sheets("Ploegen").Activate
End If
ActiveSheet.Range("C1") = RefDate


Sheets("Traject").Activate


Debug.Print "Activating Sheet Ploegen for : " & RefDate
With Sheets("Traject")
StartCol = .Range(Kolom("Start Op") & 1).Column
EindCol = .Range(Kolom("Eindigt Op") & 1).Column
REindCol = .Range(Kolom("Reele Einddatum") & 1).Column
PloegCol = .Range(Kolom("Ploeg") & 1).Column
NameCol = .Range(Kolom("Naam") & 1).Column
RRCol = .Range(Kolom("Rijksregister") & 1).Column
End With

ActiveSheet.AutoFilterMode = False

Set Filter = Worksheets("Traject").Range("Actief_Bereik")

For Each Ploeg In Range("Ploegen")

Sheets("Traject").Activate
With Filter
.AutoFilter
.AutoFilter Field:=StartCol, Criteria1:="<=" & CDbl(RefDate)
.AutoFilter Field:=REindCol, Criteria1:=" ", Operator:=xlOr, Criteria2:=">=" & CDbl(RefDate)
.AutoFilter Field:=PloegCol, Criteria1:=Ploeg

'On Error GoTo Niks
Set Rng = Range("Actief_Bereik").Offset(1).Resize(Range("Actief_Bereik").Rows.Count - 1).SpecialCells(xlCellTypeVisible)
Rng.Select
' Set Rng = Range("A" & Range("ColumnHeaders").Row).CurrentRegion.SpecialCells(xlCellTypeVisible)
Debug.Print "Ploeg " & Ploeg & ": " & Rng.Address

If Rng.Areas.Count > 1 Then

Debug.Print Ploeg & ": Non Contiguous cells : Separate!" & Rng.Address
Set Multiplerange = Nothing
rwCount = 0
For Each RngArea In Rng.Areas
rwCount = rwCount + RngArea.Rows.Count
If Multiplerange Is Nothing Then
Set Multiplerange = Union(RngArea.Columns(1), RngArea.Columns(3), RngArea.Columns(4), _
RngArea.Columns(13), RngArea.Columns(15))
Else
Set Multiplerange = Union(Multiplerange, RngArea.Columns(1), RngArea.Columns(3), RngArea.Columns(4), _
RngArea.Columns(13), RngArea.Columns(15))
'Set multiplerange = Application.Union(range1, range2)
End If
Next RngArea
Debug.Print "Areas: " & Multiplerange.Address

Multiplerange.Offset(1, 0).Select

MsgBox "Ploeg " & Ploeg & " Selection Copied"


Multiplerange.Copy
Else
Debug.Print Ploeg & "Contiguous cells :: should copy without problem! " & Rng.Address
Union(Rng.Columns(1), Rng.Columns(3), Rng.Columns(4), Rng.Columns(13), Rng.Columns(15)).Select ' Essentie!!! Union om kolommnen te kopieren!!
Selection.Offset(1, 0).ResizeCopy
rwCount = Selection.Row.Count
End If


' Debug.Print Union(Rng.Columns(1), Rng.Columns(2), Rng.Columns(4))


With Sheets("Ploegen")
'.Activate
Application.GoTo Sheets("Ploegen").Range(Ploeg)

Set PloegData = ActiveCell.CurrentRegion
With PloegData ' TODO: check for extra blank lines and remove also
If (.Rows.Count > 1) Then
Set PloegData = PloegData.Resize(PloegData.Rows.Count - 1)
Set PloegData = PloegData.Offset(1)
.ClearContents
End If
Range(Ploeg).Offset(1, -1).Activate


'ActiveCell.Offset(1, -1).Activate 'Move new range down to Start at the fisrt data row.
'MsgBox "Paste hier " & Ploeg
ActiveCell.PasteSpecial (xlPasteValues)
'ActiveCell.Offset(rwCount, 0).Select
End With

'With Sheets("Test")
' .Activate
' ActiveCell.PasteSpecial (xlPasteValues)
' ActiveCell.Offset(rwCount, 0).Select


'End With

Application.CutCopyMode = False ' Clear Copy Buffer!!!


End With
Niks:
End With


Next Ploeg


End Sub