Autofill the formulas and supress the messages

[Robert Hargreaves]

Hi I am using some code I have had help on here in the past with but in
different subjects.

The Problem is that now I have a tried the code out on a live spreadsheet it
is doing one or two things I didnt expect.

No errors but when I run the code it does not copy formaulas down as
autofill but the date column only. The other problem is that some of the
named ranges are also copied and I get messages asking me if I would like to
name them the same or change them. I always want to keep them the same. Is
there a way to do this in VBA with my code?

Dim mnthlgth As Long
Dim iLastRow As Long
Dim wsArchive As Worksheet

Path = ThisWorkbook.Path & "\"
Name = Mid(ThisWorkbook.Name, 1, Len(ThisWorkbook.Name) - 4)

Set wsArchive = Application.Workbooks(Name &
"Archive.xls").Sheets(ActiveSheet.Name)

If ActiveSheet.Range("$A$5").Value Like "01/01/*" Then
ActiveSheet.Rows("5:35").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:35").Delete
mnthlgth = 31
ElseIf ActiveSheet.Range("$A$5").Value = #2/1/2008# Then
ActiveSheet.Rows("5:33").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:33").Delete
mnthlgth = 33
ElseIf ActiveSheet.Range("$A$5").Value = #2/1/2012# Then
ActiveSheet.Rows("5:33").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:33").Delete
mnthlgth = 33
ElseIf ActiveSheet.Range("$A$5").Value = #2/1/2016# Then
ActiveSheet.Rows("5:33").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:33").Delete
mnthlgth = 33
ElseIf ActiveSheet.Range("$A$5").Value Like "01/02/*" Then
ActiveSheet.Rows("5:32").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:32").Delete
mnthlgth = 32
ElseIf ActiveSheet.Range("$A$5").Value Like "01/03/*" Then
ActiveSheet.Rows("5:35").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:35").Delete
mnthlgth = 31
ElseIf ActiveSheet.Range("$A$5").Value Like "01/04/*" Then
ActiveSheet.Rows("5:34").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:34").Delete
mnthlgth = 32
ElseIf ActiveSheet.Range("$A$5").Value Like "01/05/*" Then
ActiveSheet.Rows("5:35").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:35").Delete
mnthlgth = 32
ElseIf ActiveSheet.Range("$A$5").Value Like "01/06/*" Then
ActiveSheet.Rows("5:34").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:34").Delete
mnthlgth = 31
ElseIf ActiveSheet.Range("$A$5").Value Like "01/07/*" Then
ActiveSheet.Rows("5:35").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:35").Delete
mnthlgth = 32
ElseIf ActiveSheet.Range("$A$5").Value Like "01/08/*" Then
ActiveSheet.Rows("5:35").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:35").Delete
mnthlgth = 31
ElseIf ActiveSheet.Range("$A$5").Value Like "01/09/*" Then
ActiveSheet.Rows("5:34").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:34").Delete
mnthlgth = 32
ElseIf ActiveSheet.Range("$A$5").Value Like "01/10/*" Then
ActiveSheet.Rows("5:35").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:35").Delete
mnthlgth = 32
ElseIf ActiveSheet.Range("$A$5").Value Like "01/11/*" Then
ActiveSheet.Rows("5:34").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:34").Delete
mnthlgth = 29
ElseIf ActiveSheet.Range("$A$5").Value Like "01/12/*" Then
ActiveSheet.Rows("5:35").Cut
Destination:=wsArchive.Range("A65536").End(xlUp)
ActiveSheet.Rows("5:35").Delete
mnthlgth = 32
End If

Workbooks(Name & "Archive.xls").Close SaveChanges:=True

iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Cells(iLastRow, "A").AutoFill Cells(iLastRow, "A").Resize(mnthlgth)

Error:

MsgBox ("You must have an archive file open to archive data"), vbInformation

Exit Sub

Thanks
Rob

 

[JE McGimpsey]

One way (replace the 10 in Resize(1, 10) with the number of rows:

Dim wsArchive As Worksheet
Dim mnthlgth As Long
Dim sPath As String
Dim sName As String

With ThisWorkbook
sPath = .Path & Application.PathSeparator
sName = Left(.Name, Len(.Name) - 4) & "Archive.xls"
End With
Set wsArchive = Application.Workbooks(sName).Sheets(ActiveSheet.Name)

With ActiveSheet.Range("A5")
mnthlgth = Day(DateSerial(Year(.Value), Month(.Value) + 1, 0))
With .Resize(mnthlgth, 1).EntireRow
.Copy Destination:=wsArchive.Cells( _
Rows.Count, 1).End(xlUp).Offset(1, 0)
.Delete
End With
End With
wsArchive.Parent.Close savechanges:=True
With Cells(Rows.Count, 1).End(xlUp).EntireRow
.AutoFill .Resize(mnthlgth + 1), xlFillDefault
End With