simplification possible d'un programme sous VBA

Version imprimable

bonjour

me revoila; j'ai mis un peu de temps mais je suis parvenu à faire ce que je recherchais

Ci joint le programme que j'ai réalisé. Il est un peu long si les données sont nombreuses. peut on simplifier et accelerer le mouvement?
par ailleurs, ce n'est pas encore tout à fait au point. En effet, je voudrais que ces donnees mises en forme nourrissent une base de donnee (excel) c'est à dire se copient à la suite des précedentes sans les effacer. (Exemple: les n lignes de la feuille se mettent automatiquement à la suite des m lignes du fichier precedent.Pouvez vous m'aider? (deux colonnes sont à exclure lors de ce procede)
Merci de votre aide

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
Sub transfert()
Dim Ligne_lue As Long
Ligne_lue = 2 'initialisation de la variable
'separateur des cellule plaquette
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("IMPORT DU TERRAIN").Select
    Cells(Ligne_lue, 1).Select
    Selection.Copy
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 4).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Selection.TextToColumns Destination:=Sheets("Feuil1").Cells(Ligne_lue, 4), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
    Ligne_lue = Ligne_lue + 1
Wend
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("IMPORT DU TERRAIN").Select
    Cells(Ligne_lue, 2).Select
    Selection.Copy
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 3).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Ligne_lue = Ligne_lue + 1
Wend
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 1) = Ligne_lue - 1
    Ligne_lue = Ligne_lue + 1
Wend
'recherche du code de l'essence
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 2).FormulaR1C1 = "=VLOOKUP(RC[1],qualite!R2C4:R28C5,1)"
    Ligne_lue = Ligne_lue + 1
Wend
 
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("IMPORT DU TERRAIN").Select
    Cells(Ligne_lue, 3).Select
    Selection.Copy
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 7).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Ligne_lue = Ligne_lue + 1
Wend
 
'Operation sur diametre en m
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 8).FormulaR1C1 = "='IMPORT DU TERRAIN'!RC[-3]/100"
    Ligne_lue = Ligne_lue + 1
Wend
 
'Conditions pour ID IT
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 6).FormulaR1C1 = "=IF(RC[-1]="""","""",IF(RC[-1]<90,""ID"",""IT""))"
    Ligne_lue = Ligne_lue + 1
Wend
 
'reduction longueur en m
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 9).FormulaR1C1 = _
        "=IF('IMPORT DU TERRAIN'!RC[-5]=0,0,'IMPORT DU TERRAIN'!RC[-5]/100)"
    Ligne_lue = Ligne_lue + 1
Wend
 
'Qualité
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 10).FormulaR1C1 = _
        "=VLOOKUP('IMPORT DU TERRAIN'!RC[-3],qualite!R2C1:R13C2,2)"
    Ligne_lue = Ligne_lue + 1
Wend
 
'calcul pieces
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 11).FormulaR1C1 = "=IF(RC[-5]=""ID"",0,1)"
    Ligne_lue = Ligne_lue + 1
Wend
 
'Calcul mesures
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 12).FormulaR1C1 = "=IF(RC[-4]<>0,1,0)"
    Ligne_lue = Ligne_lue + 1
Wend
 
'Calcul grumes
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 13).FormulaR1C1 = "=IF(RC[-7]="""",1,0)"
    Ligne_lue = Ligne_lue + 1
Wend
 
'Calcul volume net
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 14).FormulaR1C1 = "=ROUND((RC[-7]-RC[-5])*RC[-6]*RC[-6]*PI()/4,3)"
    Ligne_lue = Ligne_lue + 1
Wend
 
'Calcul volume brut
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 15).FormulaR1C1 = "=ROUND(RC[-8]*RC[-7]*RC[-7]*PI()/4,3)"
    Ligne_lue = Ligne_lue + 1
Wend
 
'Nom propriétaire
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
Sheets("IMPORT DU TERRAIN").Select
    Range("A1").Select
    Selection.Copy
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 17).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Ligne_lue = Ligne_lue + 1
Wend
 
'Parcelle
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("IMPORT DU TERRAIN").Select
    Range("B1").Select
    Selection.Copy
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 18).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Ligne_lue = Ligne_lue + 1
Wend
 
'Date
Ligne_lue = 2 'initialisation de la variable
While Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1) <> ""
    Sheets("IMPORT DU TERRAIN").Select
    Range("C1").Select
    Selection.Copy
    Sheets("Feuil1").Select
    Cells(Ligne_lue, 19).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
    Ligne_lue = Ligne_lue + 1
Wend
 
End Sub

28/01/2012, 00h12
jfontaine

Bonjour,

Le code serait plus lisible s'il était positionné entre des balises Code (le # dans la barre d'outil).

Je vais être direct, mais ton code est ce que l'on appel un "usine a gaz" :aie::mrgreen:

Tu boucles sur toutes les lignes de l'onglet "IMPORT DU TERRAIN" , fais une action, et recommence une nouvelle boucle etc ....

Pourquoi ne pas faire toutes les actions dans une seule boucle?
28/01/2012, 03h25
Benoit Schwob
Bonsoir,

Une piste à explorer : éliminer autant de ".Select" que possible, c'est à dire à peu près tous. L'idée est de penser "objet", de comprendre les liens entre les objets, et de travailler avec.

Un passage comme celui-ci ...
Code:

1 2 3 4 5 6 Sheets("IMPORT DU TERRAIN").Select Cells(Ligne_lue, 1).Select Selection.Copy Sheets("Feuil1").Select Cells(Ligne_lue, 4).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
... dit exactement la même chose que ça :
Code:

1 2 Sheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 1).Copy Sheets("Feuil1").Cells(Ligne_lue, 4).PasteSpecial Paste:=xlPasteValues
Et puis aère ton code (sauts de ligne, indentation), il va devenir nettement plus lisible !

Benoît
28/01/2012, 09h46
lps02

merci

Je suis débutant mais vais essayer de suivre vos conseils. pour moi, difficile de faire toutes les actions en meme temps puisque il y a des calculs....

Pouvez vous me donner des piste? De meme pour la copie automatique des resultats dans une BD sans effacer les valeurs precedentes (Numerotation des lignes je pense...)

Merci encore pour tous vos conseils

Bonjour,

A mon avis, le problème principal posé par ton code, c’est qu’il n’est pas conçu pour répondre directement à ce que tu cherches à faire, a savoir une fiche d’historisation de résultats.
Si j’ai bien compris, la feuille IMPORT DU TERRAIN sert aux relevés et la feuille "Feuil1" est une feuille de calcul et de résultats.
Les données de la feuille IMPORT DU TERRAIN sont "écrasées" à chaque relevé.
Les résultats dans la feuille "Feuil1" doivent être « historisés ».
C’est ce dernier point qui pose problème car les formules utilisent des références relatives.

Exemple :
Quand tu codes pour l’operation sur diametre :
Worksheets("Feuil1").Cells(2, 8).FormulaR1C1 = "='IMPORT DU TERRAIN'!RC[-3]/100"
La procédure inscrit dans la cellule H2 de Feuil1 la formule "='IMPORT DU TERRAIN'!E2/100"
Lorsque tu voudras effectuer un deuxième traitement, la formule dans Feuil1 sera déplacée du nombre de lignes du relevé (100 lignes par exemple).
La formule deviendra "='IMPORT DU TERRAIN'!E102/100"
Le résultat sera erroné puisque la donnée dans IMPORT DU TERRAIN sera toujours en E2.

Si tu souhaites conserver la conception avec des formules, tu peux créer une troisième feuille HISTORIQUE dans laquelle tu effectueras une copie des résultats obtenus dans Feuil1.

Autre solution, tu modifies ton code afin que Feuil1 devienne une simple fiche de résultats.
Dans ce cas, il n’y a plus de formules dans Feuil1. Les calculs sont effectués dans la procédure.
Pour reprendre l’exemple précédent, tu écriras
Worksheets("Feuil1").Cells(Ligne_copie, 8) = Worksheets("IMPORT DU TERRAIN").Cells(Ligne_lue, 5)
Avec Ligne_copie = DerLig1 + Ligne_lue – 1
DerLig1 étant le numéro de la dernière ligne renseignée de la feuille "Feuil1".
DerLig1 = Worksheets("Feuil1")..Range("A" & Worksheets("Feuil1").Rows.Count).End(xlUp).Row

Tu trouveras ci-dessous le code qui correspond à cette solution.
J’ai intégré les remarques de Jérôme et Benoit.
Si cette solution t’intéresse, prends le temps d’effectuer des tests pour vérifier qu’il n’y a pas d’erreur dans les transcriptions de formules.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
Sub transfert()
Dim Ligne_lue As Long
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
 
Application.ScreenUpdating = False
Set Ws1 = Worksheets("Feuil1")
Set Ws2 = Worksheets("IMPORT DU TERRAIN")
Set Ws3 = Worksheets("qualite")
 
'initialisation du n° de ligne à copier
Ligne_lue = 2
'Recherche de la dernière ligne renseignée de la feuille "Feuil1".
DerLig1 = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row
With Ws2
While .Cells(Ligne_lue, 1) <> ""
    'Détermination du n° de la ligne de la feuille "Feuil1" où est effectuée la copie.
    Ligne_copie = DerLig1 + Ligne_lue - 1
    'separateur des cellule plaquette
    .Cells(Ligne_lue, 1).Copy
    Ws1.Cells(Ligne_copie, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
    Selection.TextToColumns Destination:=Ws1.Cells(Ligne_copie, 4), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
 
    .Cells(Ligne_lue, 2).Copy
    Ws1.Cells(Ligne_copie, 3).PasteSpecial Paste:=xlPasteValues
 
    Ws1.Cells(Ligne_copie, 1) = Ligne_lue - 1
 
    'recherche du code de l'essence
    'Ws1.Cells(Ligne_copie, 2).FormulaR1C1 = "=VLOOKUP(RC[1],qualite!R2C4:R28C5,1)"
    Ws1.Cells(Ligne_copie, 2) = Application.WorksheetFunction.VLookup(Ws2.Cells(Ligne_lue, 3), Ws3.Range("$D$2:$E$28"), 1)
 
    .Cells(Ligne_lue, 3).Copy
    Ws1.Cells(Ligne_copie, 7).PasteSpecial Paste:=xlPasteValues
 
    'Operation sur diametre en m
    'Ws1.Cells(Ligne_copie, 8).FormulaR1C1 = "='IMPORT DU TERRAIN'!RC[-3]/100"
    Ws1.Cells(Ligne_copie, 8) = Ws2.Cells(Ligne_lue, 5) / 100
 
    'Conditions pour ID IT
    'Ws1.Cells(Ligne_copie, 6).FormulaR1C1 = "=IF(RC[-1]="""","""",IF(RC[-1]<90,""ID"",""IT""))"
    If Ws1.Cells(Ligne_copie, 5) <> "" Then
        If Ws1.Cells(Ligne_copie, 5) < 90 Then
            Ws1.Cells(Ligne_copie, 6) = "ID"
        Else
            Ws1.Cells(Ligne_copie, 6) = "IT"
        End If
    Else
        Ws1.Cells(Ligne_copie, 6) = ""
    End If
 
    'reduction longueur en m
    'Ws1.Cells(Ligne_copie, 9).FormulaR1C1 = "=IF('IMPORT DU TERRAIN'!RC[-5]=0,0,'IMPORT DU TERRAIN'!RC[-5]/100)"
    If Ws2.Cells(Ligne_lue, 4) = 0 Then
        Ws1.Cells(Ligne_copie, 9) = 0
    Else
        Ws1.Cells(Ligne_copie, 9) = Ws2.Cells(Ligne_lue, 4) / 100
    End If
 
    'Qualité
    'Ws1.Cells(Ligne_copie, 10).FormulaR1C1 = "=VLOOKUP('IMPORT DU TERRAIN'!RC[-3],qualite!R2C1:R13C2,2)"
    Ws1.Cells(Ligne_copie, 10) = Application.WorksheetFunction.VLookup(Ws2.Cells(Ligne_lue, 7), Ws3.Range("$A$2:$B$13"), 1)
 
    'calcul pieces
    'Ws1.Cells(Ligne_copie, 11).FormulaR1C1 = "=IF(RC[-5]=""ID"",0,1)"
    If Ws1.Cells(Ligne_copie, 6) = "ID" Then
        Ws1.Cells(Ligne_copie, 11) = 0
    Else
        Ws1.Cells(Ligne_copie, 11) = 1
    End If
 
    'Calcul mesures
    'Ws1.Cells(Ligne_copie, 12).FormulaR1C1 = "=IF(RC[-4]<>0,1,0)"
    If Ws1.Cells(Ligne_copie, 8) <> 0 Then
        Ws1.Cells(Ligne_copie, 12) = 1
    Else
        Ws1.Cells(Ligne_copie, 12) = 0
    End If
 
    'Calcul grumes
    'Ws1.Cells(Ligne_copie, 13).FormulaR1C1 = "=IF(RC[-7]="""",1,0)"
    If Ws1.Cells(Ligne_copie, 6) = "" Then
        Ws1.Cells(Ligne_copie, 13) = 1
    Else
        Ws1.Cells(Ligne_copie, 13) = 0
    End If
 
    'Calcul volume net
    'Ws1.Cells(Ligne_copie, 14).FormulaR1C1 = "=ROUND((RC[-7]-RC[-5])*RC[-6]*RC[-6]*PI()/4,3)"
    '=ARRONDI((G2-I2)*H2*H2*PI()/4;3)
    Ws1.Cells(Ligne_copie, 14) = Round((Ws1.Cells(Ligne_copie, "G") - Ws1.Cells(Ligne_copie, "I")) * Ws1.Cells(Ligne_copie, "H") * Ws1.Cells(Ligne_copie, "H") * WorksheetFunction.Pi / 4, 3)
 
    'Calcul volume brut
    'Ws1.Cells(Ligne_copie, 15).FormulaR1C1 = "=ROUND(RC[-8]*RC[-7]*RC[-7]*PI()/4,3)"
    '=ARRONDI(G2*H2*H2*PI()/4;3)
    Ws1.Cells(Ligne_copie, 15) = Round(Ws1.Cells(Ligne_copie, "G") * Ws1.Cells(Ligne_copie, "H") * Ws1.Cells(Ligne_copie, "H") * WorksheetFunction.Pi / 4, 3)
 
    'Nom propriétaire
    .Range("A1").Copy
    Ws1.Cells(Ligne_copie, 17).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
 
    'Parcelle
    .Range("B1").Copy
    Ws1.Cells(Ligne_copie, 18).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
 
    'Date
    .Range("C1").Copy
    Ws1.Cells(Ligne_copie, 19).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
 
    Ligne_lue = Ligne_lue + 1
 
Wend
End With
Application.ScreenUpdating = True
End Sub

Bon courage

Cordialement.

29/01/2012, 21h17
lps02

Citation:

Envoyé par gFZT82

Bonjour,
(...).

Merci beaucoup.Balaise!!!

je teste et te tiens informé.

Cordialement

Apres quelques bogues,le programme fonctionne.
Est il possible plutot que de copier les donnes depuis une feuille en csv d'aller les chercher directement depuis la feuille de saisie(En clair, ne plus faire de copier coller vers la fauille "import terrain"??

Quelques pistes??

Encore mille merci