More time-effective archive method

papafernando

New Member
Joined
Feb 13, 2020
Messages
1
Office Version
365
Platform
Windows
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 #.
VBA Code:
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

Well-known Member
Joined
Dec 23, 2017
Messages
1,032
Office Version
2010
Platform
Windows
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.
VBA Code:
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

Well-known Member
Joined
Dec 23, 2017
Messages
1,032
Office Version
2010
Platform
Windows
I spotted one error :
datarr = Range(Cells(1, 1), Cells(lastrow, 3))

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

Forum statistics

Threads
1,085,183
Messages
5,382,172
Members
401,779
Latest member
Thonor

Some videos you may like

This Week's Hot Topics

Top