• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Code optimization

Pierre

Member
Hello,

I managed (with some help from here ;)) to write a macro which automatize the copy/paste data from a closed workbook that I can select to another one. The final destination workbook is a bit heavy (ca 6 Mo), while the original workbook is quite light (50ko). I copy data from different columns in 2 different worksheet in the origin workbook and copy it into 2 different worksheets, different columns in destination workbook. I then also copy down formulas.

However to run the code, it takes between 30 and 40s, which I find quite long. If I would do all these operations manually, I would probably take the same amount of time.

I think my code is probably not efficient and I was wondering if you had suggestion to run it in a more efficient manner.

Thank you!


Code:
Sub MaJ_Data_Prod()

    Dim FileToOpen As Variant
    Dim OpenBook As Workbook

   
    Application.ScreenUpdating = False
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
   
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
       
        'Copie les valeurs de l'onglet 1 (Returns Core) du fichier extérieur selectionné (OpenBook) vers onglet Returns Core du fichier cible
        OpenBook.Sheets(1).Range("A3:C3").Select
        Range(Selection, Selection.End(xlDown).Offset(-1)).Copy
        ThisWorkbook.Worksheets("Returns Core").Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'Copie à partir de la 1ere ligne vide
       
        OpenBook.Sheets(1).Range("D3:N3").Select
        Range(Selection, Selection.End(xlDown).Offset(-1)).Copy
        ThisWorkbook.Worksheets("Returns Core").Range("M" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'Copie à partir de la 1ere ligne vide
       
       
        'Copie les valeurs d'un onglet3 (Problem Solving) du fichier extérieur vers onglet Problem Solving du fichier cible
        OpenBook.Sheets(3).Activate
        OpenBook.Sheets(3).Range("A2:C2").Select
        Range(Selection, Selection.End(xlDown).Offset(-1)).Copy
        ThisWorkbook.Worksheets("Problem Solving").Activate
        ThisWorkbook.Worksheets("Problem Solving").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'Copie à partir de la 1ere ligne vide
       
        OpenBook.Sheets(3).Activate
        OpenBook.Sheets(3).Range("D2:J2").Select
        Range(Selection, Selection.End(xlDown).Offset(-1)).Copy
        ThisWorkbook.Worksheets("Problem Solving").Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'Copie à partir de la 1ere ligne vide
       
        OpenBook.Close False
       
        'AutofillDown des formules en A:G, K:L et X:Y de l'onglet Returns Core
        ThisWorkbook.Worksheets("Returns Core").Activate
        Range("A2:G2").Select
        Selection.AutoFill Destination:=Range("A2:G" & Range("H" & Rows.Count).End(xlUp).Row)
        Range(Selection, Selection.End(xlDown)).Select
       
        Range("K2:L2").Select
        Selection.AutoFill Destination:=Range("K2:L" & Range("H" & Rows.Count).End(xlUp).Row)
        Range(Selection, Selection.End(xlDown)).Select
       
        Range("X2:Y2").Select
        Selection.AutoFill Destination:=Range("X2:Y" & Range("H" & Rows.Count).End(xlUp).Row)
        Range(Selection, Selection.End(xlDown)).Select
       
        'Reproduction de la mise en forme
        Rows("2:2").Select
        Selection.Copy
        Range(Selection, Selection.End(xlDown)).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Range(Selection, Selection.End(xlDown)).Select
       
        'AutofillDown des formules en D:E et M:M de l'onglet Problem Solving
        ThisWorkbook.Worksheets("Problem Solving").Activate
        Range("D2:E2").Select
        Selection.AutoFill Destination:=Range("D2:E" & Range("A" & Rows.Count).End(xlUp).Row)
        Range(Selection, Selection.End(xlDown)).Select
   
        Range("M2:M2").Select
        Selection.AutoFill Destination:=Range("M2:M" & Range("A" & Rows.Count).End(xlUp).Row)
        Range(Selection, Selection.End(xlDown)).Select
       
        'Reproduction de la mise en forme
        Rows("2:2").Select
        Selection.Copy
        Range(Selection, Selection.End(xlDown)).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Range(Selection, Selection.End(xlDown)).Select
       
        ThisWorkbook.Worksheets("Returns Core").Activate
       
   
    End If
   
   
    Application.ScreenUpdating = True
   
End Sub
 
It sounds like you don't like your code.
There might be a good chance the the people willing and able to help you don't like it either but as it stands, you want them to wade through it and fix it.
Would it be too much to ask for you to split your problems up and have a thread for each problem?
You are copying and pasting, auto filling ranges with formulas, copying and pasting formats I think.
If you get a good piece of code for each, you can then put it into one macro.
BTW, read up on why not to use select and activate.

As an example, this should be faster for your copying and pasting the ranges AFTER you changed the references to what they should be.
Code:
Sub MaJ_Data_Prod()
Dim FileToOpen As Variant
Dim wb1 As Workbook, wb2 As Workbook
Dim val1, val2, val3, val4
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then Set wb2 = Application.Workbooks.Open(FileToOpen)
val1 = wb2.Sheets(1).Cells(3, 1).Resize(wb2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(-3).Row, 3).Value    '<---- Change required
val2 = wb2.Sheets(1).Cells(3, 4).Resize(wb2.Sheets(1).Cells(Rows.Count, 4).End(xlUp).Offset(-3).Row, 11).Value    '<---- Change required
val3 = wb2.Sheets(2).Cells(2, 1).Resize(wb2.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(-2).Row, 3).Value    '<---- Change required
val4 = wb2.Sheets(2).Cells(2, 4).Resize(wb2.Sheets(2).Cells(Rows.Count, 4).End(xlUp).Offset(-2).Row, 7).Value    '<---- Change required
    With wb1
    With .Sheets("Sheet4")    '<---- Change required
        .Cells(.Rows.Count, 8).End(xlUp).Offset(1).Resize(UBound(val1, 1), UBound(val1, 2)).Value = val1
        .Cells(.Rows.Count, 13).End(xlUp).Offset(1).Resize(UBound(val2, 1), UBound(val2, 2)).Value = val2
    End With
    With .Sheets("Sheet5")    '<---- Change required
        .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(val3, 1), UBound(val3, 2)).Value = val3
        .Cells(.Rows.Count, 6).End(xlUp).Offset(1).Resize(UBound(val4, 1), UBound(val4, 2)).Value = val4
    End With
    End With
wb2.Close False
Application.ScreenUpdating = True
End Sub
 
Would this do the AutoFill for you
Code:
Sub AutoFill_Returns_Core()
Dim lr As Long
    With Sheets("Returns Core")
        lr = .Cells(.Rows.Count, 8).End(xlUp).Row
        .Range("A2:G2").AutoFill .Range("A2:G" & lr), Type:=xlFillDefault
        .Range("K2:L2").AutoFill .Range("K2:L" & lr), Type:=xlFillDefault
        .Range("X2:Y2").AutoFill .Range("X2:Y" & lr), Type:=xlFillDefault
    End With
End Sub
Just going in stages to make sure we analized your code properly.
 
Hello Jolivanes,

Thanks a lot for your help!

It sounds like you don't like your code.
:D
Yes, as you probably guessed I'm not a vba expert and most of the time putting together pieces of code that I find and adapt to my needs, but probably not in the best way ;)

I have a question regarding the val variables and what they are doing exactly: do they represent a range of data that we copy from the original workbook and paste to the destination workbook?

For the autofill, do you suggest to make a separate macro for this task, or is it possible (advisable?) to run this as a "sub-macro" inside the main macro?
 
Ok, thanks to your great help I was able to adapt and it runs well: now the macro is running is 15-16s instead of 30 to 40s! The code is indeed much cleaner and I start to understand why not to use activate and select (even if the set and with isn't totally crystal clear yet :p)

I have a question regarding the
Cells(Rows.Count, 1).End(xlUp).Offset(-3)
part. I'm not quite sure how the 1 and -3 works. When I tried with a small test file, whatever number I put instead of 1, result is the same, as long as this number isn't too high.

For the -3 part, as I understand it will change the last row of the selection. However, on a small test file, I see that it doesnt take the last row as the range (as I want it), but when I tried on my "real file" with bigger range, it takes the last row of the range, even if I change the number to -1 or -2. But if I put -4, it works as expected...
 
Last edited:
The 15 seconds is still a long time. Do you know which part is the culprit?
Formatting is usually slows things down. I'll have a look at that part later.
It would be very helpfull if we had a copy of both files (no private data in it though)

As far as the case of having one macro or 3 shorter macros, in your situation I think I would prefer 3 macros.
It makes things easier for maintenance/changes.
In the first macro, if you change this
Code:
wb2.Close False
Application.ScreenUpdating = True
End Sub
to this
Code:
wb2.Close False
Application.ScreenUpdating = True
AutoFill_Returns_Core    '<--- add the 2nd macro name
End Sub
It will run the first macro and then the second one. You won't notice the difference.
Once when you have the third part (copying formats) as a separate macro, you can change this in the 2nd macro
Code:
.Range("X2:Y2").AutoFill .Range("X2:Y" & lr), Type:=xlFillDefault
    End With
End Sub
to this
Code:
.Range("X2:Y2").AutoFill .Range("X2:Y" & lr), Type:=xlFillDefault
    End With
 '<----here the name of the third macro
End Sub
and all should be well.

When finding the last used cell in a column, you can use
Code:
 Cells(Rows.Count, 1).End(xlUp).Row
'Here Column A (= 1)
You add .Offset(1) if you want the empty cell below the last used cell.
If, for example you have a column filled from A1 to A100, the "Cells(Rows.Count, 1).End(xlUp).Row" will be 100
Resizing a range starts with the range/cell you're starting from as 1. So "Resize(1, 1)" does actually nothing.
Select a cell and run this macro.
Code:
Sub Resize_try()
ActiveCell.Resize(1, 1).Select
End Sub
Now if you use that same scenario for resizing, you have to take in consideration where your starting point is
BTW, for some reason I thought you wanted to copy to the cell above the last used cell. My mistake.
Instead of me trying to explain it, do the following.
In an empty sheet, fill column A from Cell A1 to Cell A25 with anything you want. Just put something in all cells.
Now run this piece of code
Code:
Sub Trial_Code()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "The last used cell in Column A is in row " & lr
Cells(lr, 1).Select
MsgBox "Do you see where I am?"
Cells(1, 1).Resize(lr).Select
MsgBox "Do you see the selected range?"
Cells(6, 1).Resize(lr).Select    '<---- used just lr
MsgBox "Do you see the selected Range? Just started lower, that's all."
Cells(6, 1).Resize(lr - 5).Select    '<---- used lr and the lower start difference
MsgBox "Do you see the result of the - 5?"
End Sub
After you do this and things are not clear yet, let us know.
 
Read the previous Post, Post #6, first.

If you select whole Rows and/or Columns, as you do for your format copy/paste, you stand a good chance of ending up with a very bloated workbook.
If your workbook is very big in size, you should rectify that.
One way would be to select all the columns past your last used column and delete them.
Do the same with your rows. Select all the rows below the last used row and delete them.
Do that for all your sheets. Save the file.
If you have code using whole Rows (like "Rows("2:2").Select) and/or Columns, in a similar manner, change that to actual range required before continuing.
If you have done all of this and your code is cleaned, it should speed up the running of it considerably.
If you have a chance to attach copies of your original workbooks we can have a look.
This would be a better alternative for the FormatPaste for both sheets.
Code:
Sub Copy_And_Paste_Formats()
Dim lc As Long, lr As Long, wsArr, i As Long
wsArr = Array("Returns Core", "Problem Solving")
Application.ScreenUpdating = False
    For i = LBound(wsArr) To UBound(wsArr)
        With Worksheets(wsArr(i))
            lc = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
                lr = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
                .Range(.Cells(1, 1), .Cells(1, lc)).Copy
            .Range(.Cells(2, 1), .Cells(lr, lc)).PasteSpecial Paste:=xlPasteFormats
        End With
    Next i
Application.ScreenUpdating = True
End Sub
 
Wow, thanks a lot for all these explanations. That's a lot of information to take in, I have to read and dive in it calmly and test these code lines. I will get back to you in maybe a few days but I'm really grateful for taking the time to explain it thoroughly, it helps me a lot to better understands VBA :)
 
Last edited:
Back
Top