Macro :Transfert de données dans une autre feuille excel

**bakaouf** · 27/07/2010, 09h16

Bonjour
J´ai créé un ptit programme permettant de transférer des données dans différentes pages en fonction de la valeur d´une cellule et dans chaque pages de les mettre dans une plage de colonnes (7 colonnes ici) en fonction de la valeur d´une autre cellule. Le pb est qu avec ma méthode les données se retrouve à la meme ligne que dans la page initiale, il y a donc une multitude de cellules vides, j´ai donc ajouter qq choses pour supprimer ttes les cellules vides mais ce programme est vraiment long. Il se peut que j ai plus de 1000 lignes de temps en temps et le programme calcule pendant plus de 5 min.
Mon programme :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub DeleteWarning()
 
 
Dim DerLig As Long, l As Long, i As Long, k As Long, ib As Long, kb As Long, ih As Long, kh As Long, ip As Long, kp As Long, LastRowb As Long, LastRowh As Long, LastRowp As Long, h As Long, b As Long, p As Long
 
 
Dim CL As Range
 
 ' Delete all rows where there are  a warning which not stop the turbine
With Sheets(1)
    DerLig = .Range("A65000").End(xlUp).Row
    For l = DerLig To 3 Step -1
        If .Cells(l, 11).Value = 0 Then
            If CL Is Nothing Then
                Set CL = .Cells(l, 11)
            Else
                Set CL = Union(.Cells(l, 11), CL)
            End If
        End If
    Next l
    Set CL = CL.EntireRow
    CL.Delete
End With
 
'Put data in the correst sheet and in the correct turnines column
DerLig = Sheets("ExportedData").Range("A65000").End(xlUp).Row
 
For i = DerLig To 3 Step -1
    For k = 1 To 6
        If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 3).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(2, 3).Value Then Sheets("Bruck").Cells(i, k).Value = Sheets("ExportedData").Cells(i, k).Value
            If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 3).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(3, 3).Value Then Sheets("Bruck").Cells(i, k + 7).Value = Sheets("ExportedData").Cells(i, k).Value
                If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 3).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(4, 3).Value Then Sheets("Bruck").Cells(i, k + 14).Value = Sheets("ExportedData").Cells(i, k).Value
                    If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 3).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(5, 3).Value Then Sheets("Bruck").Cells(i, k + 21).Value = Sheets("ExportedData").Cells(i, k).Value
                        If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 3).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(6, 3).Value Then Sheets("Bruck").Cells(i, k + 28).Value = Sheets("ExportedData").Cells(i, k).Value
                            If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(2, 4).Value Then Sheets("Hollerm").Cells(i, k).Value = Sheets("ExportedData").Cells(i, k).Value
                                If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(3, 4).Value Then Sheets("Hollerm").Cells(i, k + 7).Value = Sheets("ExportedData").Cells(i, k).Value
                                    If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(4, 4).Value Then Sheets("Hollerm").Cells(i, k + 14).Value = Sheets("ExportedData").Cells(i, k).Value
                                        If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(5, 4).Value Then Sheets("Hollerm").Cells(i, k + 21).Value = Sheets("ExportedData").Cells(i, k).Value
                                            If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(6, 4).Value Then Sheets("Hollerm").Cells(i, k + 28).Value = Sheets("ExportedData").Cells(i, k).Value
                                                If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(7, 4).Value Then Sheets("Hollerm").Cells(i, k + 35).Value = Sheets("ExportedData").Cells(i, k).Value
                                                    If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(8, 4).Value Then Sheets("Hollerm").Cells(i, k + 42).Value = Sheets("ExportedData").Cells(i, k).Value
                                                        If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(9, 4).Value Then Sheets("Hollerm").Cells(i, k + 49).Value = Sheets("ExportedData").Cells(i, k).Value
                                                            If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 4).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(10, 4).Value Then Sheets("Hollerm").Cells(i, k + 56).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(2, 5).Value Then Sheets("Petronell").Cells(i, k).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                    If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(3, 5).Value Then Sheets("Petronell").Cells(i, k + 7).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                        If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(4, 5).Value Then Sheets("Petronell").Cells(i, k + 14).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                            If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(5, 5).Value Then Sheets("Petronell").Cells(i, k + 21).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                                If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(6, 5).Value Then Sheets("Petronell").Cells(i, k + 28).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                                    If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(7, 5).Value Then Sheets("Petronell").Cells(i, k + 35).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                                        If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(8, 5).Value Then Sheets("Petronell").Cells(i, k + 42).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                                            If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(9, 5).Value Then Sheets("Petronell").Cells(i, k + 49).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                                                If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(10, 5).Value Then Sheets("Petronell").Cells(i, k + 56).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                                                    If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(11, 5).Value Then Sheets("Petronell").Cells(i, k + 63).Value = Sheets("ExportedData").Cells(i, k).Value
                                                                                                        If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 5).Value And Sheets("ExportedData").Cells(i, 7).Value = Sheets("WarningAndError").Cells(12, 5).Value Then Sheets("Petronell").Cells(i, k + 70).Value = Sheets("ExportedData").Cells(i, k).Value
 
    Next k
Next i
 
'Delete all cells where there are nothing inside
With Sheets("Bruck")
For b = 1 To 35 Step 7
 
    LastRowb = Sheets("bruck").Cells(65000, b).End(xlUp).Row
 
    For ib = LastRowb To 3 Step -1
        For kb = 1 To 35
 
        If .Cells(ib, kb).Value = "" Then .Cells(ib, kb).Delete xlShiftUp
 
        Next kb
    Next ib
Next b
End With
 
With Sheets("petronell")
For p = 1 To 63 Step 7
LastRowp = Sheets("petronell").Cells(65000, p).End(xlUp).Row
    For ip = LastRowp To 3 Step -1
        For kp = 1 To 77
 
            If .Cells(ip, kp).Value = "" Then .Cells(ip, kp).Delete xlShiftUp
 
        Next kp
    Next ip
Next p
End With
 
With Sheets("Hollerm")
 
For h = 1 To 63 Step 7
LastRowh = Sheets("Hollerm").Cells(65000, h).End(xlUp).Row
    For ih = LastRowh To 3 Step -1
        For kh = 1 To 63
 
            If .Cells(ih, kh).Value = "" Then .Cells(ih, kh).Delete xlShiftUp
 
        Next kh
    Next ih
Next h
End With
 
 
 
 
 
End Sub

Voilà si qq a une solution plus rapide je suis preneur.

Merci

**delphine35** · 27/07/2010, 12h13

Bonjour,

Utilise plutot

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

cells(.Rows.Count,1)

au lieu de range("A65000") ou cells(65000,1)

Le probleme de rapidité vient de 2 choses :
1- Tu repete la condition suivant environ 30 fois (1 seule fois dans mon code)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If Sheets("ExportedData").Cells(i, 8).Value = Sheets("WarningAndError").Cells(1, 3).Value

et idem pour les autres
2- Tu boucles : pour ib et kb cela correspond aux lignes et aux colonnes, mais pour b je ne comprend pas ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
For b = 1 To 35 Step 7
 
    LastRowb = .Cells(.Rows.Count, 1).End(xlUp).Row
 
    For ib = LastRowb To 3 Step -1
        For kb = 1 To 35
 
        If .Cells(ib, kb).Value = "" Then .Cells(ib, kb).Delete xlShiftUp
 
        Next kb
    Next ib
Next b

J'ai modifié quelques trucs :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub DeleteWarning()
 
 
Dim DerLig, l, i, k, ib, kb, ih, kh, g, ip, kp, LastRowb, LastRowh, LastRowp, h, b, p As Long
 
Dim F1, F2, F3, F4, F5 As Worksheet
 
 
Set F1 = Worksheets("ExportedData")
Set F2 = Worksheets("WarningAndError")
Set F3 = Worksheets("Bruck")
Set F4 = Worksheets("Hollerm")
Set F5 = Worksheets("Petronell")
 
Dim CL As Range
 
 ' Delete all rows where there are  a warning which not stop the turbine
With Sheets(1)
    DerLig = .Cells(.Rows.Count, 1).End(xlUp).Row
    For l = DerLig To 3 Step -1
        If .Cells(l, 11).Value = 0 Then
            If CL Is Nothing Then
                Set CL = .Cells(l, 11)
            Else
                Set CL = Union(.Cells(l, 11), CL)
            End If
        End If
    Next l
    Set CL = CL.EntireRow
    CL.Delete
End With
 
'Put data in the correst sheet and in the correct turnines column
DerLig = F1.Cells(F1.Rows.Count, 1).End(xlUp).Row
 
For i = DerLig To 3 Step -1
 
    For k = 1 To 6
 
        If F1.Cells(i, 8).Value = F2.Cells(1, 3).Value Then
            Select Case F1.Cells(i, 7).Value
                Case F2.Cells(2, 3).Value
                                F3.Cells(i, k).Value = F1.Cells(i, k).Value
                Case F2.Cells(3, 3).Value
                                F3.Cells(i, k + 7).Value = F1.Cells(i, k).Value
                Case F2.Cells(4, 3).Value
                                F3.Cells(i, k + 14).Value = F1.Cells(i, k).Value
                Case F2.Cells(5, 3).Value
                                F3.Cells(i, k + 21).Value = F1.Cells(i, k).Value
                Case F2.Cells(6, 3).Value
                                F3.Cells(i, k + 28).Value = F1.Cells(i, k).Value
            End Select
        Else
        If F1.Cells(i, 8).Value = F2.Cells(1, 4).Value Then
            Select Case F1.Cells(i, 7).Value
 
                Case F2.Cells(2, 4).Value
                                F4.Cells(i, k).Value = F1.Cells(i, k).Value
                Case F2.Cells(3, 4).Value
                                F4.Cells(i, k + 7).Value = F1.Cells(i, k).Value
                Case F2.Cells(4, 4).Value
                                F4.Cells(i, k + 14).Value = F1.Cells(i, k).Value
                Case F2.Cells(5, 4).Value
                                F4.Cells(i, k + 21).Value = F1.Cells(i, k).Value
                Case F2.Cells(6, 4).Value
                                F4.Cells(i, k + 28).Value = F1.Cells(i, k).Value
                Case F2.Cells(7, 4).Value
                                F4.Cells(i, k + 35).Value = F1.Cells(i, k).Value
                Case F2.Cells(8, 4).Value
                                F4.Cells(i, k + 42).Value = F1.Cells(i, k).Value
                Case F2.Cells(9, 4).Value
                                F4.Cells(i, k + 49).Value = F1.Cells(i, k).Value
                Case F2.Cells(10, 4).Value
                                F4.Cells(i, k + 56).Value = F1.Cells(i, k).Value
            End Select
        Else
        If F1.Cells(i, 8).Value = F2.Cells(1, 5).Value Then
            Select Case F1.Cells(i, 7).Value
 
                Case F2.Cells(2, 5).Value
                                F5.Cells(i, k).Value = F1.Cells(i, k).Value
                Case F2.Cells(3, 5).Value
                                F5.Cells(i, k + 7).Value = F1.Cells(i, k).Value
                Case F2.Cells(4, 5).Value
                                F5.Cells(i, k + 14).Value = F1.Cells(i, k).Value
                Case F2.Cells(5, 5).Value
                                F5.Cells(i, k + 21).Value = F1.Cells(i, k).Value
                Case F2.Cells(6, 5).Value
                                F5.Cells(i, k + 28).Value = F1.Cells(i, k).Value
                Case F2.Cells(7, 5).Value
                                F5.Cells(i, k + 35).Value = F1.Cells(i, k).Value
                Case F2.Cells(8, 5).Value
                                F5.Cells(i, k + 42).Value = F1.Cells(i, k).Value
                Case F2.Cells(9, 5).Value
                                F5.Cells(i, k + 49).Value = F1.Cells(i, k).Value
                Case F2.Cells(10, 5).Value
                                F5.Cells(i, k + 56).Value = F1.Cells(i, k).Value
                Case F2.Cells(11, 5).Value
                                F5.Cells(i, k + 63).Value = F1.Cells(i, k).Value
                Case F2.Cells(12, 5).Value
                                F5.Cells(i, k + 70).Value = F1.Cells(i, k).Value
            End Select
        End If
        End If
        End If
    Next k
Next i
 
'Delete all cells where there are nothing inside
With F3
For b = 1 To 35 Step 7
 
    LastRowb = .Cells(.Rows.Count, 1).End(xlUp).Row
 
    For ib = LastRowb To 3 Step -1
        For kb = 1 To 35
 
        If .Cells(ib, kb).Value = "" Then .Cells(ib, kb).Delete xlShiftUp
 
        Next kb
    Next ib
Next b
End With
 
With F5
For p = 1 To 63 Step 7
    LastRowp = .Cells(.Rows.Count, 1).End(xlUp).Row
    For ip = LastRowp To 3 Step -1
        For kp = 1 To 77
 
            If .Cells(ip, kp).Value = "" Then .Cells(ip, kp).Delete xlShiftUp
 
        Next kp
    Next ip
Next p
End With
 
With F4
 
For h = 1 To 63 Step 7
LastRowh = .Cells(.Rows.Count, h).End(xlUp).Row
    For ih = LastRowh To 3 Step -1
        For kh = 1 To 63
 
            If .Cells(ih, kh).Value = "" Then .Cells(ih, kh).Delete xlShiftUp
 
        Next kh
    Next ih
Next h
End With
 
 
End Sub

**bakaouf** · 27/07/2010, 13h36

Merci pour cette réponse, je vais tester tt de suite ton code et revient vers toi après.

le b dans ce code permet de changer la référence colonne pour la dernière ligne car il n y aura pas le meme nombre de données dans chaque colonne et je ne connais pas par avance quelle est la colonne qui a le plus grand nombre de valeur, c´est la raison pour laquelle je dois tester toutes les colonnes,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
With Sheets("Bruck")
For b = 1 To 35 Step 7
 
    LastRowb = Sheets("bruck").Cells(65000, b).End(xlUp).Row
 
    For ib = LastRowb To 3 Step -1
        For kb = 1 To 35
 
        If .Cells(ib, kb).Value = "" Then .Cells(ib, kb).Delete xlShiftUp
 
        Next kb
    Next ib
Next b

**delphine35** · 27/07/2010, 13h49

Dans ce cas, recherche d'abord le nbre max de lignes du fichier (idem pour les autres)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
With Sheets("Bruck")
LastRowb = 0
 
For b = 1 To 35 
    tt = .Cells(.rows.count, b).End(xlUp).Row
    if tt > LastRowb then 
         LastRowb = tt
    end if 
next b
 
For ib = LastRowb To 3 Step -1
        For kb = 1 To 35
 
        If .Cells(ib, kb).Value = "" Then .Cells(ib, kb).Delete xlShiftUp
 
        Next kb
Next ib

question : pourquoi tu met step 7 ?

**bakaouf** · 27/07/2010, 14h14

Je met step 7 car je veux seulement voir ce qu il y a tte les 7 collones, car a la 6ème coonnes est vides, elle est dédié à un autre programme
Merci je vais tester ton code

ok
Merci pour ton aide, le programme travaille un peu plus rapidement.

Macro :Transfert de données dans une autre feuille excel

Macros et VBA Excel

Discussions similaires

Partager

Partager