More time-effective archive method

[papafernando]

I am in the process of creating an electronic filing system which involves upwards of 300 subjects at any one time. I am fairly new to VBA and have come up with this code to examine a table with three columns - a subject #, a date, and a weight. The code exports the date and weight column to another file matching the subject #.

Sub archive()

Dim active As Workbook

Set active = Application.Workbooks.Open("C:\Users\myusername\Documents\File_System_Beta\VBA Testing\Active.xlsm")

Application.ScreenUpdating = False

For Each cell In active.Sheets("Sheet1").Range("Table1[Subject]")
    If cell.Offset(0, 1).Value > 0 Then
        Range(cell.Offset(0, 1), cell.Offset(0, 2)).Copy
        Workbooks.Open "C:\Users\myusername\Documents\File_System_Beta\VBA Testing\Subjects\" & cell.Value & ".xlsx"
            a = Cells(Rows.Count, 1).End(xlUp).Row
            Cells(a + 1, 1).PasteSpecial xlPasteValues
        ActiveWorkbook.Close SaveChanges:=True
    End If
Next cell

Application.CutCopyMode = False

Application.ScreenUpdating = True

MsgBox "Archive complete"

End Sub

This does 99% of what I want it to do. However, I tested this with eight subjects and the whole process took some time to complete. My main question is if there's any way to do this more efficiently in terms of time? Like I said, I'm going to be using this process with a couple hundred subjects and would prefer if it didn't take 10 minutes to work. Also, if I'm stuck with the more time-intensive method, is there a way that I can pull up a message box with no button that simply says "Archiving, please wait..."?

 

[offthelip]

I have modified your code to use a variant array to load all of the data in your "active" sheet, this save multiple accesses to the worksheet in the loop so it will speed up the loop. You still have all the time taken to open and close all the files,which might be significant.
Note it is untested.

Sub archive()

Dim active As Workbook  ' "Active" as a name is a poor choice because ActiveWorkbook is easily confused with it

Set active = Application.Workbooks.Open("C:\Users\myusername\Documents\File_System_Beta\VBA Testing\Active.xlsm")
With active.Worksheets("Sheet1")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row

datarr = Range(Cells(1, 1), Cells(lastrow, 3))
Application.ScreenUpdating = False
End With
'For Each cell In active.Sheets("Sheet1").Range("Table1[Subject]")
For i = 1 To lastrow
     If datarr(i, 2) > 0 Then
'    If cell.Offset(0, 1).Value > 0 Then
'        Range(cell.Offset(0, 1), cell.Offset(0, 2)).Copy
        Workbooks.Open "C:\Users\myusername\Documents\File_System_Beta\VBA Testing\Subjects\" & datarr(i, 1) & ".xlsx"
            a = Cells(Rows.Count, 1).End(xlUp).Row
'            Cells(a + 1, 1).PasteSpecial xlPasteValues
             Cells(a + 1, 1) = datarr(i, 2)
             Cells(a + 1, 2) = datarr(i, 3)
        ActiveWorkbook.Close SaveChanges:=True
    End If
Next i

Application.ScreenUpdating = True

MsgBox "Archive complete"

End Sub

 

[offthelip]

I spotted one error :
datarr = Range(Cells(1, 1), Cells(lastrow, 3))

shouild be
datarr = Range(.Cells(1, 1), .Cells(lastrow, 3))