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
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top