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

Just Fateh

New Member
Joined
Jul 12, 2019
Messages
2
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
 

jkpieterse

Well-known Member
Joined
Dec 3, 2007
Messages
972
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
 

Just Fateh

New Member
Joined
Jul 12, 2019
Messages
2
this does not solve the problem, it's still take too long to run the code

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
 

jkpieterse

Well-known Member
Joined
Dec 3, 2007
Messages
972
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.
 

Forum statistics

Threads
1,082,576
Messages
5,366,419
Members
400,888
Latest member
Cdim7

Some videos you may like

This Week's Hot Topics

Top