Discussion :

[gribouille_]

Bonjour,

[Sous Excel 2007 / 2010]
J'ai un souci de mouvement de cellules, je m'explique j'ai une transposition de cellule à faire en fonction de valeur de colonnes référence.

Je m'explique par une image:



J'ai environ 15000 à 20000 lignes.
J'ai beau essayer de transposer de faire des décalage de lignes etc etc bref je ne m'en sort pas et impossible de gérer 20000 lignes comme ça
Les couleurs dans les cellules ne sont là que pour le forum pour plus de clarté

Si vous avez une petite routine pour faire ça, ça serait vraiment un grand pas en avant pour moi dans ce monde vba !!!

Merci

[jijie]

ça c'est pour patrick !

[gribouille_]

Ah excellent si en plus il y a des gens qui sont tout désigné avec des prédispositions pour ça

avec des bout de macro enregistré ça marchouille mais c'est vraiment pas jouable sur 20000lignes et des 10aines de réf différente !

[jijie]

Oui mais il faut chercher de toi même sinon ça ne fonctionne pas !!!

essai un bout de code et présente le nous même si ça ne marche pas, c'est en forgeant que l'on devient forgeron !

[gribouille_]

Je suis bien d'accord mais qu'est-ce que je galère !!!

voilà mon bricolage je me suis inspiré de code que je trouvais à droite à gauche et pour des cases vides ça fonctionne pas encore, ça me les écrase.

et là c'est uniquement pour une réf : 100001

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
Dim j As Integer
Dim i As Integer
Dim k As Integer
Dim v As Integer
 
 
Application.ScreenUpdating = False
 For i = 2 To 30000
 For v = 0 To 10
 Sheets("liste").Select
   Range("A2").Select
   If Cells(i, 1) = "" Then
   Range("D:D").ClearContents
   Exit Sub
   End If
 
' 10000X
   If Cells(i, 1).Text = "100001" And Cells(i, 4) = "" Then
   Cells(i, 4) = "X"
  Range(Cells(i, 1), Cells(i, 3)).Copy
 
' FEUIL
   Sheets("Feuil2").Select
    Range("A1").Select
     ActiveSheet.Paste
     Application.CutCopyMode = False
 For j = 3 To 255
     If Cells(j, 1) = "" Or Cells(j, 1) = Range("A1") Then
     Cells(j, 1) = Range("A1")
 For k = 2 To 255 Step 2
     If Cells(j, k) = Range("B1") Then
     Cells(j, k + 1) = Cells(j, k + 1) + 1
     Exit For
     ElseIf Cells(j, k) = "" Then
     Cells(j, k) = Range("B1")
     Cells(j, k + 1) = Range("C1")
     Exit For
     Else
     Cells(j, k + 2).Select
     End If
 Next k
  Range("A1:C1").ClearContents
    Exit For
     Else
     Cells(j + 1, k).Select
     End If
 Next j
   Else
    Cells(i + 1, 1).Select
   End If
 Next v
 'v = v + 1
 Next i
 
 Application.ScreenUpdating = True
End Sub

Bonjour ,

Bon j'avance mais là je bloque, j'arrive à faire mes tris et mes collage dans la feuil2 mais si la ref de la feuille "liste" en colonne A contient une seconde valeur identique,
par exemple en A2 j'ai 10001 puis en A3 10001 aussi je n'arrive pas à traiter cette ligne je passe en A4 !
Pour info j'increment une variable incr sur 10000 + incr

mon code :

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
Sub ref_100000_Feuil2()
Dim lig As Integer
Dim ligliste As Integer
Dim col As Integer
Dim txt As Double
Dim NBref As Integer
Dim incr As Integer
 
 
Application.ScreenUpdating = False
'MsgBox Oui + Non
Select Case MsgBox("effacer Feuil2 et les X ?", vbYesNo, "effacer Feuil2 ?")
    Case vbYes
         Sheets("liste").Select
         Range("D:D").ClearContents
         Sheets("Feuil2").Select
         Range("A:ZZ").ClearContents
         Sheets("liste").Select
    Case vbNo
    End Select
incr = 0
 For ligliste = 2 To 65
 Sheets("liste").Select
   Range("A2").Select
   If Cells(ligliste, 1) = "" And liglist < 65 Then
   Range("D:D").ClearContents
   'ElseIf liglist = 62 Then
   ElseIf Cells(ligliste, 1) = "fin" Then
   MsgBox "fin de colonne"
   Exit Sub
   End If
 
' 10000X
   If Cells(ligliste, 1).Text = "10000" & incr And Cells(ligliste, 4) = "" Then
 
' "X" => "pour valider ce qui est fait"
   Cells(ligliste, 4) = "X"
   txt = "10000" & incr
   NBref = Application.WorksheetFunction.CountIf(Range("A:A"), "=" & txt)
   Range(Cells(ligliste, 1), Cells(ligliste, 3)).Copy
 
' FEUIL2
   Sheets("Feuil2").Select
    Range("A1").Select
     ActiveSheet.Paste
     Application.CutCopyMode = False
For lig = 3 To 255
     If Cells(lig, 1) = "" Or Cells(lig, 1) = Range("A1") Then
     Cells(lig, 1) = Range("A1")
 For col = 2 To 255 Step 2
     If Cells(lig, col) = Range("A1") Then
     Cells(lig, col + 1) = Cells(lig, col + 1)
     Exit For
     ElseIf Cells(lig, col) = "" Then
     Cells(lig, col) = Range("B1")
     Cells(lig, col + 1) = Range("C1")
     Exit For
     Else
     Cells(lig, col + 2).Select
     End If
 Next col
  Range("A1:C1").ClearContents
    Exit For
     Else
     Cells(lig + 1, col).Select
     End If
 Next lig
    Cells(ligliste + 1, 1).Select
 
   End If
   'incr = incr + 1
 Next ligliste
 
 Application.ScreenUpdating = True
End Sub

[Marc-L]

Rappel du post #7 (sans compter les #12 & #14 !) :

Sinon avec un classeur exemple en pièce jointe …

Je n'ai pas à me cogner la saisie des données, ce n'est pas compliqué de fournir un classeur exemple !

Il y a souvent des différences entre une vague explication et des données concrètes débouchant sur une perte de temps,
je préfère un one shot code à partir d'une présentation claire & exhaustive accompagnée de données reflétant le besoin réel.

Qui plus est, le demandeur - nouveau sur le forum - ne donne plus de ses nouvelles, donc à quoi bon ?
Soit il est allé frayer ailleurs, soit il a fini par obtenir une solution avec un tant soit peu de logique
vu la problématique niveau débutant, rien que l'utilisation de l'Enregistreur de macros met sur la voie …

Quelle que soit la solution, classique par copie de cellules ou évoluée via un dictionnaire,
un code efficace devrait tenir en largement moins de vingt lignes effectives, sinon je n'ai rien compris à la demande ‼

[patricktoulon]

Bonjour

puisque jijie insiste

lit les commentaire (envert)

je ne me suis pas occupé de la 2 Emme partie du code mais commence par analyser ceci:

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
 
Sub ref_100000_Feuil2()
Dim lig As Integer
Dim ligliste As Integer
Dim col As Integer
Dim txt As Double
Dim NBref As Integer
Dim incr As Integer
 Dim tablo As Variant
 
Application.ScreenUpdating = False
'MsgBox Oui + Non
Select Case MsgBox("effacer Feuil2 et les X ?", vbYesNo, "effacer Feuil2 ?")
    Case vbYes
         Sheets("liste").Range("D:D").ClearContents
         Sheets("Feuil2").Range("A:ZZ").ClearContents
         'bien que attention ici clearcontent supprime aussi la mise en forme
    '************************************************************************************
         'si il y a une mise en forme des cllule je suggere de faire plutot ceci:
          Sheets("liste").Range("D:D") = ""
         Sheets("Feuil2").Range("A:ZZ") = ""
    '************************************************************************************
             Case vbNo
    End Select
incr = 0
 For ligliste = 2 To 65
' plutot que travailler avec des select partout pour les sheets apprend a travailler avec des with /end with
 With Sheets("liste") 'ici on ne select pas (perte de temps et utilisation inutile de memoire
   'Range("A2").Select' je ne select pas on s'en fou en fait ca n'a aucunne utilité
   If .Cells(ligliste, 1) = "" And liglist < 65 Then
   .Range("D:D").ClearContents 'ici pareil si tu a une mise en forme prefere utiliser le ( ="" )
   'ElseIf liglist = 62 Then
   ElseIf .Cells(ligliste, 1) = "fin" Then
   MsgBox "fin de colonne"
   Exit Sub
   End If
 
' 10000X
  'attention ici que veux tu determiner 10000 & INCR VAUT 10000XXX
 '10000+INCR VAUT EXEMPLE INCR=5 DONC 10005 CE QUI N'EST PAS LA MEME CHOSE MAIS CA JE NE PEUT PAS LE SAVOIR A TA PLACE
 If .Cells(ligliste, 1).Text = "10000" & incr And .Cells(ligliste, 4) = "" Then
 ' "X" => "pour valider ce qui est fait"
   .Cells(ligliste, 4) = "X"
   txt = "10000" & incr
   NBref = Application.WorksheetFunction.CountIf(.Range("A:A"), "=" & txt) 'cette ligne te sert a quoi???????
 
   'MAUVAISE METHODE
   '.Range(.Cells(ligliste, 1), .Cells(ligliste, 3)).Copy
 ' FEUIL2
  ' Sheets("Feuil2").Select 'mauvaise methode
   ' Range("A1").Select 'mauvaise methode
   '  ActiveSheet.Paste 'mauvaise methode
   '  Application.CutCopyMode = False 'mauvaise methode
'on va faire ceci: a la place
tablo = .Range(.Cells(ligliste, 1), .Cells(ligliste, 3))
End With
'*********************************************************************************************************
'meilleure  METHODE
With Sheets("Feuil2") 'PUISQUE A PARTIR D'ici on travaille sur la feuil2 alors un with et non un select
.Range("A1").Resize(ligliste, 3) = tablo
'comme tu peut le constater en une ligne je fait la meme chose que toi en 5 ou 6 ligne et sans select
 
'****************************************************************************************************
'2 eme partie du code
For lig = 3 To 255
      If .Cells(lig, 1) = "" Or .Cells(lig, 1) = .Range("A1") Then
     .Cells(lig, 1) = .Range("A1")
 
 For col = 2 To 255 Step 2
 
     If .Cells(lig, col) = .Range("A1") Then
     .Cells(lig, col + 1) = .Cells(lig, col + 1)
 
     Exit For
     ElseIf .Cells(lig, col) = "" Then
     .Cells(lig, col) = Range("B1")
     .Cells(lig, col + 1) = .Range("C1")
     Exit For
     Else
     .Cells(lig, col + 2).Select ' pour quoi cela? a quoi te sert de selectionner une cell dans une boucle
 
     End If
 Next col
  .Range("A1:C1").ClearContents ' ici pareil attention a la mise en forme des cellules
    Exit For
     Else
     .Cells(lig + 1, col).Select ' pour quoi cela? a quoi te sert de selectionner une cell dans une boucle
 
     End If
 Next lig
    .Cells(ligliste + 1, 1).Select ' pour quoi cela? a quoi te sert de selectionner une cell dans une boucle
 
   End If
   'incr = incr + 1
 Next ligliste
End With
 Application.ScreenUpdating = True
End Sub
' je nai pas optimiser la 2 eme partie du code je te laisse digerer tout ca bien que j'ai mis des commentaires