HowTo optimise use of .select and reduce the 10 min that it takes to collate 600 tables into 1 RRS feed

  • General discussion

  • Dear friends, I have the following issue with a macro that collates near 600 tables (5x13) and paste them in different sheets in order.
    In other words, the macro builds a DB with hundreds of tables distributed in several sheets.

    Because it needs to copy and paste so many cells the macro became really really inefficient changing sheets and extracting all data. It can take literally 10 minutes the whole process.

    I don't know how to optimise. I have looked for answers the last 2 weeks but I have made really tiny improvements. I still use for example many sheets().select

    Please... what can I do? The code is the following

    Sub Extractor()
    ' byYearExtractor Macro
        Dim i As Integer
        Dim n As Integer
        Dim Range2 As Range, Range1 As Range
        Dim Source As String, Destiny As String, TableName As String, AdditionalColumn As String
        Dim UniqueDestinyArray As Variant, FullDestinyArray As Variant
        Dim flagsSource As Boolean, flagDestiny As Boolean
        Dim ws As Worksheet
        On Error GoTo errHandler
        Application.ScreenUpdating = False
        Set ws = ActiveSheet
        NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count - 1
        If NumRows = 0 Or NumRows > 1000 Then
        MsgBox ("insert a table to load or less than 500 tables")
        Exit Sub
        End If
        'Clear tables in Destiny Sheets
        FullDestinyArray = Range("E2", Range("E2").End(xlDown))
        UniqueDestinyArray = UniqueItems(FullDestinyArray, False)
        For i = LBound(UniqueDestinyArray) + 1 To UBound(UniqueDestinyArray)
        Destiny = UniqueDestinyArray(i)
        If Sheets(Destiny).Visible = False Then flagDestiny = True
        If Sheets(Destiny).Visible = False Then Sheets(Destiny).Visible = True
        'Load tables
        For i = 0 To NumRows - 1
            Do While ActiveCell(i + 1, 8).Value = "NO"
            i = i + 1
            If ActiveCell(i + 1, 8).Value = "YES" Then
            Set Range1 = ActiveCell(i + 1, 2)
            'MsgBox (Range1)
            Set Range2 = ActiveCell(i + 1, 3)
            'MsgBox (Range2)
            Source = ActiveCell(i + 1, 1)
            'MsgBox Source
            Destiny = ActiveCell(i + 1, 5)
            'No of columns
            ActiveCell(i + 1, 4).Value = Range(Range1 & ":" & Range2).Columns.Count
            numberColumns = Range(Range1 & ":" & Range2).Columns.Count
            'No of rows
            numberRows = Range(Range1 & ":" & Range2).Rows.Count
            'Optional column
            AdditionalColumn = ActiveCell(i + 1, 7)
            If Sheets(Source).Visible = False Then flagSource = True
            If Sheets(Source).Visible = False Then Sheets(Source).Visible = True
            'Get table name
            TableName = Sheets(Source).Range(Range1).Offset(-1, 0)
            Sheets(Source).Range(Range1).Offset(-1, 0).Copy
            ActiveCell(i + 1, 6).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            'Get data table
            Sheets(Source).Range(Range1 & ":" & Range2).Copy
            If Sheets(Destiny).Visible = False Then flagDestiny = True
            If Sheets(Destiny).Visible = False Then Sheets(Destiny).Visible = True
            Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            Application.CutCopyMode = False
                For n = 0 To Range(Range1 & ":" & Range2).Rows.Count - 1
                ActiveCell.Offset(n + 1, 0).Value = TableName
            'If AdditionalColumn <> "" Then Range("A1").End(xlDown).End(xlToRight).Offset(0, 1).End(xlUp).Activate
            If AdditionalColumn <> "" Then
                Range("A1").End(xlDown).Offset(-numberRows, numberColumns + 1).Select
                For Z = 0 To Range(Range1 & ":" & Range2).Rows.Count - 1
                ActiveCell.Offset(Z + 1, 0).Value = AdditionalColumn
            End If
            AdditionalColumn = ""
            If flagSource = True Then Sheets(Source).Visible = False
            If flagSource = True Then flagSource = False
            If flagDestiny = True Then Sheets(Destiny).Visible = False
            If flagDestiny = True Then flagDestiny = False
        End If
        Application.ScreenUpdating = True
        Application.ScreenUpdating = True
    End Sub
    Take note that in "LoadTable" you have by row the info that you need to collate the data in the other sheets, such as
    - Sheet name of source
    - Initial and ending cell
    - Sheet name of destination
    - A cell for adding a column (which is optional and it will add in every row in the last column whatever is put there)
    - And a flag YES / NO so I can choose which lines to load

    The macro basically in few steps
    1- cleans the destiny sheets
    2- looks for the tables in the ranges and sheets written in LoadTable and it pastes those tables in the destiny sheet
    3- for each line or row copied it adds also the name of the table in the first column
    4- and if there is an additional column that want to be added to the db that is being built, it does it for every row in the last column

    What can I do to optimise the macro? Many thanks

    Thursday, July 30, 2015 3:43 AM

All replies

  • Hi Geronimo,

    I would be looking to redesign the entire process if possible!

    Excel is great for calculation but it sounds like you need to do more processing with the tables in a database rather than in excel.

    Do the 600 tables get viewed or updated by users? - if not then why load them? Can these be stored in an Access or similar Database and then queried for the required results - a much more efficient process...

    Brian, ProcessIT- Hawke`s Bay, New Zealand

    Thursday, July 30, 2015 10:20 PM