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

T

timpie_s

New Member
Joined
Feb 26, 2013
Messages
18
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:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Tom [/TD]
[TD]Sawyer [/TD]
[TD]1/12/2013 [/TD]
[TD]15/2/2014[/TD]
[TD]Painter1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ellen[/TD]
[TD]Decree[/TD]
[TD]1/5/2013[/TD]
[TD]16/4/2014[/TD]
[TD]Carpenter[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Yves[/TD]
[TD]Show[/TD]
[TD]1/5/2013[/TD]
[TD]18/6/2014[/TD]
[TD]Painter2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mark[/TD]
[TD]Fall[/TD]
[TD]1/8/2014[/TD]
[TD][/TD]
[TD]Builder[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Preferred Output = Template which is needed for our personnel manager
Date: 1/2/2014 ==> This Date Is where [TABLE="width: 500"]
<tbody>[TR]
[TD]Date[/TD]
[TD]1/2/2014[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Painter1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Tom [/TD]
[TD]Sawyer[/TD]
[TD]1/12/2013[/TD]
[TD]15/2/2014[/TD]
[TD]...[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Painter2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Yves[/TD]
[TD]Show[/TD]
[TD]1/5/2013[/TD]
[TD]18/6/2014[/TD]
[TD]...[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Carpenter[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Ellen[/TD]
[TD]Decree[/TD]
[TD]1/5/2013[/TD]
[TD]16/4/2014[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Builder[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Mark[/TD]
[TD]Fall[/TD]
[TD]1/8/2014[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
You must log in or register to reply here.

Similar threads

L
  • Question Question
Selection based on two variables - copy and paste to another sheet
Replies
3
Views
348
kvsrinivasamurthy
K
A
  • Question Question
VBA Copy/Paste New Data Only
Replies
0
Views
422
ah2024_2024
A
H
  • Solved
Consolidate data from selected sheets into master sheet & automatically update data.
Replies
8
Views
1K
Joe4
Joe4
G
  • Question Question
Workbook formulas copied with Sheet references in new Workbook
Replies
0
Views
389
GK039
G
V
  • Question Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
506
VanGirl
V

Forum statistics

Threads
1,223,275
Messages
6,171,127
Members
452,381
Latest member
Nova88

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top