Vba comparaison ligne à ligne. optimiser

Fermé
feelingood - Modifié par feelingood le 26/07/2012 à 13:33
 feelingood - 26 juil. 2012 à 15:55
Hello les pros du vba!
J'ai besoin de vos supers pouvoirs..

J'ai fait un programme vba, il tourne pour 178 lignes mais pour 8000 lignes, il plante et je ne sais pas comment faire pour l'optimiser.

Voila le fameux programme:
(au fait la c'est juste un bout d'un programme assez long donc s'il manque la déclaration de certaines variable c'est qu'elles sont "public" et ont été déclarées avant :) mais bon jsuis sure que vous le savez déja ^^)

Sub siorgane()

'Dim b As Long
'Dim c As Long
Dim dateech As Date
Dim aujourdhui As Date
Dim x As Integer
WaitX.Show vbModeless
WaitX.Caption = "Copie des données en cours"
WaitX.Label1.Caption = "Veuillez patienter..."
WaitX.Repaint

x = 0
'nbre de ligne du tableau: stocké dans "g"
aujourdhui = Date
'"c" est la ligne de sauv
'"b" est la ligne de charge_eo
' g est le nombre de lignes

c = 0
b = 0
' g = 6555 (juste pour essai)
'Sub bouclelongue1()
While Not IsEmpty(Sheets("sauv").Cells(x + 6, 1))
c = x + 6
b = i + 6
While Not IsEmpty(Sheets("CHARGE_EO").Cells(i + 6, 1))

b = i + 6

'-----------------------------------C'EST ICI: le principal axe d'optimisation je pense.

' ThisWorkbook.Worksheets("CHARGE_EO").Cells(b, 1).Value
If ThisWorkbook.Worksheets("CHARGE_EO").Cells(b, 1).Value = ThisWorkbook.Worksheets("sauv").Cells(c, 1).Value And Worksheets("CHARGE_EO").Range("B" & b).Value = Worksheets("sauv").Range("B" & c).Value And Worksheets("CHARGE_EO").Range("C" & b).Value = Worksheets("sauv").Range("C" & c).Value And Worksheets("CHARGE_EO").Range("D" & b).Value = Worksheets("sauv").Range("D" & c).Value And Worksheets("CHARGE_EO").Range("E" & b).Value = Worksheets("sauv").Range("E" & c).Value And Worksheets("CHARGE_EO").Range("F" & b).Value = Worksheets("sauv").Range("F" & c).Value And Worksheets("CHARGE_EO").Range("G" & b).Value = Worksheets("sauv").Range("G" & c).Value And Worksheets("CHARGE_EO").Range("H" & b).Value = Worksheets("sauv").Range("H" & c).Value _
And Worksheets("CHARGE_EO").Range("I" & b).Value = Worksheets("sauv").Range("I" & c).Value And Worksheets("CHARGE_EO").Range("J" & b).Value = Worksheets("sauv").Range("J" & c).Value And Worksheets("CHARGE_EO").Range("K" & b).Value = Worksheets("sauv").Range("K" & c).Value And Worksheets("CHARGE_EO").Range("L" & b).Value = Worksheets("sauv").Range("L" & c).Value And Worksheets("CHARGE_EO").Range("M" & b).Value = Worksheets("sauv").Range("M" & c).Value And Worksheets("CHARGE_EO").Range("N" & b).Value = Worksheets("sauv").Range("N" & c).Value And Worksheets("CHARGE_EO").Range("O" & b).Value = Worksheets("sauv").Range("O" & c).Value And Worksheets("CHARGE_EO").Range("P" & b).Value = Worksheets("sauv").Range("P" & c).Value _
And Worksheets("CHARGE_EO").Range("Q" & b).Value = Worksheets("sauv").Range("Q" & c).Value And Worksheets("CHARGE_EO").Range("R" & b).Value = Worksheets("sauv").Range("R" & c).Value Then
dateech = ThisWorkbook.Sheets("CHARGE_EO").Range("N" & b).Value
datederog = ThisWorkbook.Sheets("sauv").Range("V" & b).Value
reponse = ThisWorkbook.Sheets("sauv").Range("U" & b).Value
'si périmé 'MsgBox dateech' If dateech <= aujourdhui Then
'MsgBox dateech

'''''''''''''''''''''''''''''''''''''''''''''''si perimé dans un mois ou perimé

If Month(aujourdhui) = 12 And (Month(dateeech) = 1 Or Month(dateech) = 12) And Year(dateech) <= Year(aujourdhui) + 1 _
Or (Year(dateech) = Year(aujourdhui)) And (Month(dateech) <= Month(aujourdhui) + 1) Or dateech <= aujourdhui Then
'reponse = "Accord" And
'If dateech <= datederog Then

copie_des_données_de_sauv_dans_charge_eo

'End If

End If
End If



i = i + 1
Wend
i = 0
'MsgBox b
x = x + 1
Wend
WaitX.Hide
end sub


''''''''''''''''''''''''''''''''''''''''''''' copie des données de "sauv" dans "charge_eo"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub copie_des_données_de_sauv_dans_charge_eo()



ThisWorkbook.Sheets("sauv").Activate
Range("T6").Select
Range("I2").Select

Range("T" & c & ":" & "V" & c).Select
Selection.Copy
ThisWorkbook.Sheets("CHARGE_EO").Activate
Application.CutCopyMode = False
ActiveSheet.Unprotect
Range("T" & b & ":" & "V" & b).Select
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''










A voir également:

2 réponses

alors j'ai testé avec 1941 lignes.
et je regarder le gestionnaire de tâches>performances et bien qu'excel ne réponde pas l'unité centrale est en pleine activité du coup pour une fois dans ma vie j'ai été patiente et en fait mon programme marche.
Là je le teste avec 5138 lignes et le suspens est insoutenables.

Quel magnifique monologue! :p

Merci quand meme à ceux qui ont réfléchis à mon problème :)
1
Alors le programme est un peu mieux mais plante à la ligne 824 help please :'(

Sub siorgane()

Dim dateech As Date
Dim aujourdhui As Date
Dim x As Integer

WaitX.Show vbModeless
WaitX.Caption = "Copie des données en cours"
WaitX.Label1.Caption = "Veuillez patienter..."
WaitX.Repaint

x = 0

aujourdhui = Date

c = 0
b = 0

While Not IsEmpty(Sheets("sauv").Cells(x + 6, 1))
c = x + 6
WaitX.Label1.Caption = "NB DE LIGNES A TRAITER : " & c & " / " & nbligne
WaitX.Repaint
b = i + 6
While Not IsEmpty(Sheets("CHARGE_EO").Cells(i + 6, 1))
b = i + 6

Set page_eo = ThisWorkbook.Worksheets("CHARGE_EO")
Set page_sauv = ThisWorkbook.Worksheets("sauv")

test = ThisWorkbook.Worksheets("CHARGE_EO").Cells(b, 1).Value = ThisWorkbook.Worksheets("sauv").Cells(c, 1).Value

For col = 2 To 18
test = test And page_eo.Cells(b, col) = page_sauv.Cells(c, col)
If Not (test) Then
Exit For
End If
Next col

If test Then
dateech = ThisWorkbook.Sheets("CHARGE_EO").Range("N" & b).Value
datederog = ThisWorkbook.Sheets("sauv").Range("V" & b).Value
reponse = ThisWorkbook.Sheets("sauv").Range("U" & b).Value

If Month(aujourdhui) = 12 And (Month(dateeech) = 1 Or Month(dateech) = 12) And Year(dateech) <= Year(aujourdhui) + 1 _
Or (Year(dateech) = Year(aujourdhui)) And (Month(dateech) <= Month(aujourdhui) + 1) Or dateech <= aujourdhui Then
copie_des_données_de_sauv_dans_charge_eo
End If
End If

i = i + 1
Wend
i = 0
'MsgBox b
x = x + 1
Wend
WaitX.Hide

End Sub
0