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

[gerotutu]

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

[/COLOR][COLOR=#333333]Sub Extractor()[/COLOR]
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit;">'
' 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
        
    Sheets("LoadTable").Select
    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

    Sheets(Destiny).Select
    Range("A2:ZZ65563").ClearContents
    Range("A2").Select
    
    Next
    
    'Load tables
    Sheets("LoadTable").Select
    Range("A2").Select
    For i = 0 To NumRows - 1
        Do While ActiveCell(i + 1, 8).Value = "NO"
        i = i + 1
        Loop
        
        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
        'Sheets(Source).Select
        TableName = Sheets(Source).Range(Range1).Offset(-1, 0)
        Sheets(Source).Range(Range1).Offset(-1, 0).Copy
        'Sheets("LoadTable").Select
        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
        
        Sheets(Destiny).Select
        Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False
        
        Range("A65536").End(xlUp).Activate
           
            For n = 0 To Range(Range1 & ":" & Range2).Rows.Count - 1
            ActiveCell.Offset(n + 1, 0).Value = TableName
            Next
        
                        
        '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
            Next
        End If
        
        AdditionalColumn = ""
        
        Range("A1").Select
        
        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
        
        Sheets("LoadTable").Select
        Range("A2").Select
    
    End If
    
    Next
    
    ws.Activate
    Sheets("LoadTable").Select
    Application.ScreenUpdating = True
errHandler:
    Application.ScreenUpdating = True

     </code>[COLOR=#333333]End Sub[/COLOR][COLOR=#333333]

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
Geronimo

 

[mrmmickle1]

Not sure if this will help any but, you can further qualify things so you don't have to use select:

Sheets(1).Range("A1")

You could also use:

Sheets(1).Range("A1").Copy Destination:= Sheets(2).Range("A1")

If you have alot of formulas you can use this:

[B]Application.Calculation = xlCalculationManual

[COLOR=#008000]'your code[/COLOR]

[B]Application.Calculation = xlCalculationAutomatic[/B]
[/B]

You can turn off status bar updates:

[B]Application.DisplayStatusBar =[COLOR=#0000ff] False[/COLOR]
[COLOR=#008000]'Your Code[/COLOR]
[B]Application.DisplayStatusBar = [COLOR=#0000ff]True[/COLOR][/B]
[/B]

Turn off events:

Application.EnableEvents = [COLOR=#0000ff]False[/COLOR]
[COLOR=#008000]'Your Code[/COLOR]
Application.EnableEvents = [COLOR=#0000ff]True[/COLOR]

 

[gerotutu]

OMG! I don't know what happens but now it takes 20 seconds! While it works, it says that Excel "is not responding" but after some seconds... all is made!

Many thanks. Amazing help.

 

[mrmmickle1]

Your Welcome! Glad to help.