|
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 |
Autofill the formulas and supress the messages
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.Na me) 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 In article , "Robert Hargreaves" wrote: 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 |
| All times are GMT +1. The time now is 07:20 AM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com