Hi
Below is a snippet from my code - the part of it which deals with writing
data older than given number of days into an archive file. Maybe it will be
for some help for you.
(Square brackets are used to get names from workbook. This code snippet is
only a part from a procedure, and there is a lot of variables defined
elsewhere. I edited variable names in a way you must be able to quess, what
they are for - but it also means I could miss some of them, so be wary about
this. The source table has some header rows, a continious block of entries,
and a predetermined number of rows at bottom with formulas and formats
prepared.)
....
' removing rows marked for deleting, determining rows to archive
i = 1
varArhive = 0
' deleting all rows marked for deleting (the ones having True in column
N:N)
Do Until i > varEntries
If Worksheets("SourceSheet").Range("N" & (varRowsInHead + i)) Then
Worksheets("SourceSheet").Rows((varRowsInHead + i) & ":" &
(varRowsInHead + i)).Delete Shift:=xlUp
' rereading names, changed when row was deleted, into variables
varUsedRows = [UsedRows]
varTotalRows = [TotalRows]
varEntries = [Entries]
Else
If Worksheets("SourceSheet").Range("B" & (varRowsInHead +
i)).Value < varStartDate Then varArhive = i
i = i + 1
End If
Loop
varStartDate = [StartDate]
varDate1 = [MinDate]
varDateX = [MaxDate]
' fixing entries older than varFix days as values
If varDate1 < Date - varFix Then
i = 0
Do While Worksheets("SourceSheet").Range("B" & (varRowsInHead + i +
1)).Value < (Date - varFix)
i = i + 1
If i = varUsedRows Then Exit Do
Loop
If i > 0 Then
Worksheets("SourceSheet").Range("J" & (varRowsInHead + 1) & ":M"
& (varRowsInHead + i)).Copy
Worksheets("SourceSheet").Range("J" & (varRowsInHead + 1) & ":M"
& (varRowsInHead + i)).PasteSpecial _
Paste:=xlValues, Operation:=xlNone
End If
End If
Worksheets("SourceSheet").Range("A4").Activate
' archiving entries - THIS IS THE PART YOU'LL INTERESTED IN MOST!
If varDate1 < varStartDate Then
' checking existence of archive file and opening it
Set fs = Application.FileSearch
With fs
.LookIn = varArchPath
.Filename = varArchFile
If .Execute(SortBy:=msoSortByFileName,
SortOrder:=msoSortOrderAscending) > 0 Then
' when found, then open the archive file
Workbooks.Open (varArchpath & varArchFile)
Worksheets("SourceSheet").Activate
varArchEnd = ActiveSheet.Cells.Find("*",
SearchDirection:=xlPrevious).Row
If varArchEnd < 3 Then varArchEnd = 3
Else
' when not found, then a new archive file is created and opened
Workbooks.Add
ActiveWorkbook.Sheets("Sheet1").Name = "SourceSheet"
ActiveWorkbook.SaveAs (varArchPath & varArchFile)
Workbooks(varFile).Worksheets("SourceSheet").Range("B" &
varRowsInHead & ":M" & varRowsInHead ).Copy
Workbooks(varArchFile).Worksheets("SourceSheet").Range("B3:M3").PasteSpecial
Paste:=8
Workbooks(varArchFile).Worksheets("SourceSheet").Range("B3:M3").PasteSpecial
Paste:=xlValues
Workbooks(varArchFile).Worksheets("SourceSheet").Range("B3:M3").PasteSpecial
Paste:=xlFormats
Workbooks(varArchFile).Worksheets("SourceSheet").Range("B3:M3").Interior.ColorIndex
= xlNone
Workbooks(varArchFile).Save
varArchEnd = 3
End If
Workbooks(varFail).Activate
End With
' writing to archive
Workbooks(varFile).Worksheets("SourceSheet").Range("B4:M" &
(varRowsInHead + varToArchive)).Copy
Workbooks(varArchFile).Worksheets("SourceSheet").Range("B" &
(varArchEnd + 1) & ":M" & (varArchEnd + varToArchive)).PasteSpecial
Paste:=xlValues
Workbooks(varArchFile).Worksheets("SourceSheet").Range("B" &
(varArchEnd + 1) & ":M" & (varArchEnd + varToArchive)).PasteSpecial
Paste:=xlFormats
Workbooks(varArchFile).Worksheets("SourceSheet").Range("B" &
(varArchEnd + 1) & ":M" & (varArchEnd + varToArchive)).Interior.ColorIndex =
xlNone
Workbooks(varArchFile).Activate
ActiveWorkbook.Worksheets("SourceSheet").Range("B4").Sort _
Key1:=Worksheets("SourceSheet").Range("B4"),
Order1:=xlAscending, _
Key2:=Worksheets("SourceSheet").Range("D4"),
Order2:=xlAscending, _
Key3:=Worksheets("SourceSheet").Range("C4"),
Order3:=xlAscending, _
Header:=xlGuess
Workbooks(varArchFile).Save
Workbooks(varArchFile).Close
Workbooks(varFail).Activate
' deleting archived rows from original workbook
Workbooks(varFail).Worksheets("SourceSheet").Rows((varRowsInHead +
1) & ":" & (varRowsInHead + varToArchive)).Delete Shift:=xlUp
' reassign new name values to according variables from workbook
varUsedRows = [UsedRows]
varTotalRows = [TotalRows]
varEntries = [Entries]
varDate1 = [MinDate]
varDateX = [MaxDate]
End If
....