Results 1 to 4 of 4

Thread: Can you make this Code smaller, and minimize the time of execution?
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Jul 2019
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Exclamation Can you make this Code smaller, and minimize the time of execution?

    hello, can you help me with that code,
    i'm new with excel (you can say that, i don't know a thing about it),
    i just create this code by: copy and past from here and there,, without knowing excatly what it does mean..
    but, he is work perfectly.
    now i have a small problem, the code is taking too long to execute??
    ( i have now 8000 row in my worksheet).
    when i delete all the database he works perfectly.

    this is the code:

    Code:
    Private Sub CopieButton_Click()
    Application.ScreenUpdating = False
    Sheets("VENTES").Select
    
    
    'Copy first data from Userform to first row of the worksheets
    Dim irow As Long
    Dim ws As Worksheet
    Set ws = Worksheets("VENTES")
    
    
    'find first row in database
    irow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    
    
    With ws
    .Range("A" & irow) = Me.NumeroBonBox.Value
    .Range("B" & irow) = Me.OpérationBox.Value
    .Range("C" & irow) = Me.DateBox.Value
    .Range("D" & irow) = Me.ClientBox.Value
    .Range("E" & irow) = Me.Produit01.Value
    .Range("I" & irow) = Me.TextBox1.Value
    .Range("G" & irow) = Me.PU01.Value
    .Range("H" & irow) = Me.Qté01.Value
    .Range("F" & irow) = Me.Total01.Value
    .Range("J" & irow) = Me.PrixG01.Value
    .Range("K" & irow) = Me.TTC.Value
    .Range("L" & irow) = Me.MontantRécu.Value
    .Range("O" & irow) = Me.PlatsRestant.Value
    .Range("N" & irow) = Me.PlatsRécu.Value
    .Range("M" & irow) = Me.MontantRestant.Value
    .Range("P" & irow) = Me.Consine.Value
    .Range("Q" & irow) = Me.Observation.Value
    
    
    End With
    '********************************
    
    
    'Copy data from Userform to worksheets
    
    
    Dim i As Integer
    For i = 2 To 9
    
    
    'find first row in database
    irow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    
    
    With ws
    .Range("A" & irow) = Me.NumeroBonBox.Value
    .Range("B" & irow) = Me.OpérationBox.Value
    .Range("C" & irow) = Me.DateBox.Value
    .Range("D" & irow) = Me.ClientBox.Value
    .Range("E" & irow) = Controls("Produit0" & i).Value
    .Range("I" & irow) = Controls("TextBox" & i).Value
    .Range("G" & irow) = Controls("PU0" & i).Value
    .Range("H" & irow) = Controls("Qté0" & i).Value
    .Range("F" & irow) = Controls("Total0" & i).Value
    .Range("J" & irow) = Controls("PrixG0" & i).Value
    .Range("L" & irow) = "0"
    .Range("N" & irow) = "0"
    .Range("P" & irow) = "0"
    
    
    End With
    Next
    '********************************
    
    
    'Copy data from Userform to worksheets
    
    
    Dim e As Integer
    For e = 0 To 2
    'find first row in database
    irow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    
    
    With ws
    .Range("A" & irow) = Me.NumeroBonBox.Value
    .Range("B" & irow) = Me.OpérationBox.Value
    .Range("C" & irow) = Me.DateBox.Value
    .Range("D" & irow) = Me.ClientBox.Value
    .Range("E" & irow) = Controls("Produit1" & e).Value
    .Range("I" & irow) = Controls("TextBox1" & e).Value
    .Range("G" & irow) = Controls("PU1" & e).Value
    .Range("H" & irow) = Controls("Qté1" & e).Value
    .Range("F" & irow) = Controls("Total1" & e).Value
    .Range("J" & irow) = Controls("PrixG1" & e).Value
    .Range("L" & irow) = "0"
    .Range("N" & irow) = "0"
    .Range("P" & irow) = "0"
    
    
    End With
    Next
    
    
    '********************************
    'clear empty contetnts
    '********************************
    Dim lngLastRow As String
    Dim lastRow As Long
    Dim lastcolumn As Long
    Dim a As Integer
    Dim b As Integer
    Dim c As Integer
    
    
    lastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    lastcolumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
    
    
    For a = lastRow To (lastRow - 12) Step -1
    For b = lastcolumn To 1 Step -1
    
    
    
    
    If Cells(a, 5).Value = "" Then
    If Cells(a - 1, 5).Value = "" Then
    Range(Cells(a, b), Cells(a - 1, b)).Select
    Selection.ClearContents
    
    
    End If
    End If
    Next
    Next
    
    
    '********************************
    'Copy data from Userform to worksheets and merge cells
    
    
    If Sheets("TDBP").Range("H21").Value <> 0 Then
    
    
    'find first row in database
    irow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    
    
    With ws
    .Range("A" & irow) = Me.NumeroBonBox.Value
    .Range("B" & irow) = Me.OpérationBox.Value
    .Range("C" & irow) = Me.DateBox.Value
    .Range("D" & irow) = Me.ClientBox.Value
    .Range("E" & irow) = Sheets("TDBP").Range("G21").Value
    .Range("F" & irow) = "0"
    .Range("G" & irow) = Me.Remise.Value
    .Range("H" & irow) = "0"
    .Range("I" & irow) = "0"
    .Range("J" & irow) = Me.Remise.Value
    .Range("L" & irow) = "0"
    .Range("N" & irow) = "0"
    .Range("P" & irow) = "0"
    .Range("E" & irow) = Sheets("TDBP").Range("G21").Value
    .Range("A" & irow, "Q" & irow).Select
    
    
       With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
       End With
       
    End With
    Else
    irow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    With ws
    .Range("A" & irow, "Q" & irow).Select
      With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
       End With
    End With
    End If
    
    
    
    
    End Sub

  2. #2
    Board Regular jkpieterse's Avatar
    Join Date
    Dec 2007
    Location
    Weert
    Posts
    894
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Can you make this Code smaller, and minimize the time of execution?

    As one of the first lines add
    Code:
    Application.ScreenUpdating = False
    and perhaps
    Code:
    Application.Calculation = xlCalculationManual
    Don't foget to turn back on:
    Code:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Regards,

    Jan Karel Pieterse
    Excel MVP jkp-ads.com

  3. #3
    New Member
    Join Date
    Jul 2019
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Can you make this Code smaller, and minimize the time of execution?

    this does not solve the problem, it's still take too long to run the code

    Quote Originally Posted by jkpieterse View Post
    As one of the first lines add
    Code:
    Application.ScreenUpdating = False
    and perhaps
    Code:
    Application.Calculation = xlCalculationManual
    Don't foget to turn back on:
    Code:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

  4. #4
    Board Regular jkpieterse's Avatar
    Join Date
    Dec 2007
    Location
    Weert
    Posts
    894
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Can you make this Code smaller, and minimize the time of execution?

    Hmmm. Best to time your routine to see which part is slow. One thing I know for sure: settting borders is slow, try commenting that last bit, see if it helps.
    Regards,

    Jan Karel Pieterse
    Excel MVP jkp-ads.com

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •