Archiving code question.

P

Peter h

Active Member
Joined
Dec 8, 2015
Messages
417
I've been working on this project for some time now. I've got a few other threads about issues I've had with the code, while I was trying to create it. So some of you guys may have seen my other posts. Well, I'm not having any issues with the code, and it works exactly as it should. I have noticed an issue it is causing with some of our record keeping, that I was hoping someone might have an idea how to fix.

First let me explain what's happening, and my issue, and then I'll post the code. I record sample analyses for 12 different sample types. Each sample type has it's own spreadsheet. We do approximately 2500-3000 samples a month, so at the end of each shift I click an archive button, and it moves all of the shifts analyses into appropriate archive files. There is an archive file for each month, that stores all of the analyses for the whole month. The archive code finds the appropriate archive file based on the date of the sample. So, for example if the sample's date is 09/02/2016 20:14 (format for the sample date and time recorded is mm/dd/yyyy hh:mm), then when I archive it, that sample will be copy and pasted into my Sept file. For record keeping purposes, we do a monthly count of samples, so in each archive file I have a separate worksheet that has count formulas so that it's all automatic, and IDEALY we should be able to just look and see what the count is at the end of each month without actually counting them.

But, here is my issue... Our companies systems date rolls over at 06:00 AM, and not at midnight. So if we get a sample that's sample date is between midnight and 6 AM on the first day of the month, then it archives into the new months file, but needs to be included in the previous month's count. So, for example if we get a sample time stamped for 09/01/2016 02:00 AM, my code puts that into the Sept. file because of the date, but for our counting purposes should actually be in the Aug. file. If I was strictly archiving this wouldn't be a big deal, but it is causing our counts to be inaccurate each month.

Here is the code. If you see anywhere I can make the appropriate changes, or have any ideas how to approach this issue, I'd really appreciate some input. Thanks.

Also, I know there is a lot of repetitiveness to the code that can probably be optimized, but I'm still fairly new to VBA and this is what I came up with that works. So I apologize for it probably looking like a jumbled mess... lol.

Code: 
Private Sub btn_Archive_Click()
  Dim I As Long
  Dim J As Long
  Dim sampleDate As Date
  Dim dateRanges(11, 1) As Date
  Dim copyBooks(11) As String
  Dim rowMoved As Boolean
  Dim wbDestination As Workbook
 Dim wbThis As Workbook
 Const wbFolder = "S:\Quality_Assurance\Asoma_Lab\Asoma Forms\Analysis Archive\2016\"
 For I = 0 To 11
     dateRanges(I, 0) = DateSerial(2016, I + 1, 1)
     dateRanges(I, 1) = DateAdd("d", -1, DateAdd("m", 1, dateRanges(I, 0))) & " 11:59:00 PM"
     copyBooks(I) = Format(dateRanges(I, 0), "mmmyyyy") & " Archive.xlsx"
 Next I
lastrow1 = Sheets("EF Slag").Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Sheets("EF Matte").Range("A" & Rows.Count).End(xlUp).Row
lastrow3 = Sheets("ISA").Range("A" & Rows.Count).End(xlUp).Row
lastrow4 = Sheets("Conv. Slag").Range("A" & Rows.Count).End(xlUp).Row
lastrow5 = Sheets("Revert").Range("A" & Rows.Count).End(xlUp).Row
lastrow6 = Sheets("Feed").Range("A" & Rows.Count).End(xlUp).Row
lastrow7 = Sheets("Other").Range("A" & Rows.Count).End(xlUp).Row
lastrow8 = Sheets("EFM STD").Range("A" & Rows.Count).End(xlUp).Row
lastrow9 = Sheets("EFS STD").Range("A" & Rows.Count).End(xlUp).Row
lastrow10 = Sheets("Mag STD").Range("A" & Rows.Count).End(xlUp).Row
lastrow11 = Sheets("Daily EFM").Range("A" & Rows.Count).End(xlUp).Row
lastrow12 = Sheets("Daily EFS").Range("A" & Rows.Count).End(xlUp).Row

 Application.EnableEvents = False
 I = 2
 Do While I <= lastrow1
     sampleDate = Sheets("EF Slag").Cells(I, 3).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("EF Slag").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("EFS").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("EF Slag").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow1 = lastrow1 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
 I = 2
 Do While I <= lastrow2
     sampleDate = Sheets("EF Matte").Cells(I, 3).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("EF Matte").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("EFM").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("EF Matte").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow2 = lastrow2 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow3
     sampleDate = Sheets("ISA").Cells(I, 3).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("ISA").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("ISA").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("ISA").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow3 = lastrow3 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow4
     sampleDate = Sheets("Conv. Slag").Cells(I, 3).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("Conv. Slag").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("Conv.").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("Conv. Slag").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow4 = lastrow4 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow5
     sampleDate = Sheets("Revert").Cells(I, 3).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("Revert").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("Revert").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("Revert").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow5 = lastrow5 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow6
     sampleDate = Sheets("Feed").Cells(I, 3).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("Feed").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("Feed").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("Feed").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow6 = lastrow6 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow7
     sampleDate = Sheets("Other").Cells(I, 3).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("Other").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("Other").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("Other").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow7 = lastrow7 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow8
     sampleDate = Sheets("EFM STD").Cells(I, 1).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("EFM STD").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("EFM STD").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("EFM STD").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow8 = lastrow8 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow9
     sampleDate = Sheets("EFS STD").Cells(I, 1).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("EFS STD").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("EFS STD").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("EFS STD").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow9 = lastrow9 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow10
     sampleDate = Sheets("Mag STD").Cells(I, 1).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("Mag STD").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("Mag STD").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("Mag STD").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow10 = lastrow10 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow11
     sampleDate = Sheets("Daily EFM").Cells(I, 1).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("Daily EFM").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("Daily EFM").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("Daily EFM").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow11 = lastrow11 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop
 
  I = 2
 Do While I <= lastrow12
     sampleDate = Sheets("Daily EFS").Cells(I, 1).Value
     rowMoved = False
     For J = 0 To 11
         If sampleDate >= dateRanges(J, 0) And sampleDate <= dateRanges(J, 1) Then
             Set wbDestination = Nothing
             On Error Resume Next
             Set wbDestination = Application.Workbooks(copyBooks(J))
             On Error GoTo 0
             If wbDestination Is Nothing Then
                 Set wbThis = ActiveWorkbook
                 Set wbDestination = Application.Workbooks.Open(wbFolder & copyBooks(J))
                 wbThis.Activate
             End If
             Sheets("Daily EFS").Cells(I, 1).EntireRow.Copy Destination:=wbDestination.Sheets("Daily EFS").Range("A" & Rows.Count).End(xlUp).Offset(1)
             Sheets("Daily EFS").Cells(I, 1).EntireRow.Delete
             rowMoved = True
             lastrow12 = lastrow12 - 1
             Exit For
         End If
     Next J
     I = I + IIf(rowMoved, 0, 1)
 Loop

 I = 1
 Do While I <= Application.Workbooks.Count
     For J = 0 To 11
         If StrComp(Application.Workbooks(I).Name, copyBooks(J), vbTextCompare) = 0 Then
             Application.Workbooks(I).Save
             Application.Workbooks(I).Close
             I = I - 1
             Exit For
         End If
     Next J
     I = I + 1
 Loop
ActiveWorkbook.Save

End Sub
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
I would have said that using the excel pc system time would be the best way to assess the time stamps

I've never heard of a system that changes date at six a.m. unless its done via coding
 
Upvote 0
If this were a worksheet, I'd recommend three columns one "clock date/time" (input the date and time), and two display columns "time" and "adjusted date"

If clock date/time were in A1, Time would be =MOD(A1,1) and "adjusted Date" would be =INT(A1-"6:00:00")

Archive based on the adjusted date value.
 
Last edited:
Upvote 0
Not sure I follow everything in the code, but I think all you need is to add the 6 AM time to the dateRanges.

Code: 
 For I = 0 To 11
     dateRanges(I, 0) = [COLOR=#FF0000]DateSerial(2016, I + 1, 1) + 6 / 24[/COLOR]
     dateRanges(I, 1) = [COLOR=#FF0000]DateSerial(2016, I + 2, 1) + 6 / 24[/COLOR]
     copyBooks(I) = Format(dateRanges(I, 0), "mmmyyyy") & " Archive.xlsx"
 Next I


Code: 
If sampleDate >= dateRanges(J, 0) And sampleDate [COLOR=#FF0000]<[/COLOR] dateRanges(J, 1) Then
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Locked
  • Question Question
Range in worksheet1 Insert into worksheet2 from row 2
Replies
1
Views
334
Fluff
Fluff
R
  • Question Question
VBA to Copy Multiple sheets to new workbook & save as .xlsb or .xlsx
2
Replies
16
Views
2K
rahildhody
R
D
  • Solved
Range in worksheet1 Insert into worksheet2 from row 2
Replies
2
Views
346
dufusgoofus
D
J
  • Question Question
Code Issue
Replies
1
Views
175
RoryA
RoryA
Z
  • Question Question
VBA Process Flow Chart using Shapes & Connectors
Replies
2
Views
140
zlotowlosapl
Z

Forum statistics

Threads
1,223,239
Messages
6,170,947
Members
452,368
Latest member
jayp2104

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