View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Robert Hargreaves Robert Hargreaves is offline
external usenet poster
 
Posts: 18
Default Autofill the formulas and supress the messages

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