Erreur dans le code

Version imprimable

Voir 40 message(s) de cette discussion en une page

21/11/2007, 11h46
ouskel'n'or

Citation:

Envoyé par ousk', réponse 7

Ensuite, les cellules que tu colles après copies seront dans des colonne consécutives. Est-ce que tu veux ?
Si oui, tu peux simplifier ton code
...
...
...
Mais comme je te l'ai dit, le résultat de ta copie se trouvera dans des colonnes consécutives.
21/11/2007, 12h10
derech

Citation:

Envoyé par ousk', réponse 7
Ensuite, les cellules que tu colles après copies seront dans des colonne consécutives. Est-ce que tu veux ?
Si oui, tu peux simplifier ton code
...
...
...
Mais comme je te l'ai dit, le résultat de ta copie se trouvera dans des colonnes consécutives.

En fait je n'avais pas bien pigé ton code.

Pour faire plus court... et embêter fred... (Salut Fred) :mouarf:
A adapter

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub copierDesCellulesNonAdjacentes()
Dim FL1 As Worksheet, adres as string, Plage As Range
Dim FL2 As Worksheet
Set FL1 = Worksheets("feuil1")
Set FL2 = Worksheets("feuil4")
i = 5
        adres = Application.Union(Range("a" & i), Range("n" & i), _
        Range("al" & i), Range("ad" & i), Range("ae" & i), Range("af" & i), _
        Range("ag" & i), Range("ah" & i), Range("ai" & i), Range("am" & i), _
        Range("an" & i), Range("ao" & i), Range("ar" & i), Range("as" & i), _
        Range("at" & i), Range("ak" & i), Range("aj" & i), Range("m" & i)).Address
        Set Plage = FL1.Range(adres) 'Plage dans FL1 (Sh pour toi)
        'Dernière ligne de la feuille où tu colles tes données
        NoLigne = FL2.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row + 1
        'Copy/Colle de chaque cellule au bon endroit
        For Each Cell In Plage
            Cell.Copy FL2.Cells(NoLigne, Cell.Column)
        Next
 
End Sub

21/11/2007, 12h25
fred65200

bonjour ouskel'n'or

:king: je n'ai pas pensé à faire une boucle sur la plage.

@+

1 pièce(s) jointe(s)

Je suis désolé ca ne marche pas..

Mes cellules de la colonne N (feuille1) se collent dans la colonne N (feuille4) alors que je veux qu'elles se collent dans la colonne B (feuille4) et c'est pareil pour les autres.

C'est peu etre que je n'ai pas adapté suffisamment ton code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
Sub copierDesCellulesNonAdjacentes()
 
Dim FL1 As Worksheet, adres As String, Plage As Range
Dim FL2 As Worksheet
Set FL1 = Worksheets("data")
Set FL2 = Worksheets("FB Fully Redeemed")
i = 5
        adres = Application.Union(Range("a" & i), Range("n" & i), _
        Range("al" & i), Range("ad" & i), Range("ae" & i), Range("af" & i), _
        Range("o" & i), Range("al" & i), Range("ad" & i), Range("ae" & i), Range("af" & i), Range("ag" & i), Range("ah" & i), Range("ai" & i), Range("am" & i), _
        Range("an" & i), Range("ao" & i), Range("ar" & i), Range("as" & i), _
        Range("at" & i), Range("ak" & i), Range("aj" & i), Range("m" & i)).Address
        Set Plage = FL1.Range(adres)
        NoLigne = FL2.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row + 1
        For Each Cell In Plage
            Cell.Copy FL2.Cells(NoLigne, Cell.Column)
        Next
 
End Sub

je vous envoi une petite partie de mon fichier.

21/11/2007, 12h48
fred65200

bonjour derech
as tu essayé ma proposition?

Citation:

Envoyé par fred65200

bonjour,
a tester

cordialement
21/11/2007, 12h52
derech

Oui j'ai testé mais sans résultat

Modifie la boucle

Code:

1
2
3
4
5
NoCol = 0
        For Each Cell In Plage
            NoCol = NoCol + 1
            Cell.Copy FL2.Cells(NoLigne, NoCol)
        Next

et déclare NoCol as byte
Edit
Si c'est ce que tu veux... :roll:

21/11/2007, 12h57
derech

j'ai modifié la boucle sur ton code ouskel'n'or mais ca me donne toujours le mem resultat, les cellules ne se collent pas au bon endroit
21/11/2007, 13h13
fred65200

1 pièce(s) jointe(s)

re

ton classeur qui fonctionne (pb de if placé au mauvais endroit entre autres)

cordialement

Tiens, testé et tout

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
Sub Test()
 
Dim FL1 As Worksheet, adres As String, Plage As Range
Dim FL2 As Worksheet, NoCol As Byte, NoLigne As Long
Set FL1 = Worksheets("Sheet1") '("data")
Set FL2 = Worksheets("sheet2") '("FB Fully Redeemed")
Dim i As Integer
Dim k As Integer
Dim derli As Integer
Dim x As String
x = "YES"
k = 8
NoCol = 0
        derli = FL1.Columns(1).Find("*", , , , , xlPrevious).Row
        For i = 5 To derli
            If FL1.Cells(i, 22).Value = x Then
                adres = Application.Union(Range("a" & i), Range("n" & i), _
                Range("al" & i), Range("ad" & i), Range("ae" & i), Range("af" & i), _
                Range("ag" & i), Range("ah" & i), Range("ai" & i), Range("am" & i), _
                Range("an" & i), Range("ao" & i), Range("ar" & i), Range("as" & i), _
                Range("at" & i), Range("ak" & i), Range("aj" & i), Range("m" & i)).Address
                Set Plage = FL1.Range(adres) 'Plage dans FL1 (Sh pour toi)
                'Dernière ligne de la feuille où tu colles tes données
                NoLigne = FL2.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row + 1
                'Copy/Colle de chaque cellule au bon endroit
                For Each cell In Plage
                    NoCol = NoCol + 1
                    'MsgBox cell.Address & "  copiée " & FL2.Cells(NoLigne, NoCol).Address
                    cell.Copy FL2.Cells(NoLigne, NoCol)
                Next
                NoCol = 0
                k = k + 1
            End If
        Next i
    i = i + 1
 
End Sub

J'avais oublié de remettre NoCol à zéro
A+

21/11/2007, 14h14
derech

Le code fonctionne ouskel'n'or mias ne me colle toujours pas les cellules au bon endroit, ma colonne N se colle en AJ par exemple

fred65200: Je ne peux pas ouvrir les pièces jointes en fait (c'est bloqué depuis le travail). Peux tu m'envoyer le code modifié? Merci

bonour,

code à mettre dans un module de code

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
 
 
 
Sub test2()
 
Dim i As Integer
Dim k As Integer
Dim derli As Integer
Dim cel As Range
Dim sh As Worksheet
Dim x As String
Dim recherche As Range
x = "YES"
k = 8
 
Set sh = Worksheets("data")
 
derli = sh.Columns(1).Find("*", , , , , xlPrevious).Row
        For i = 5 To derli
        'sh.Activate 'peut être pas nécessaire d'activer la feuille à chaque fois
            If sh.Cells(i, 22).Value = x Then
              Dim tab1(1 To 19, 1 To 1) As Variant
              Erase tab1
              tab1(1, 1) = sh.Range("a" & i).Value
              tab1(2, 1) = sh.Range("n" & i).Value
              tab1(3, 1) = sh.Range("o" & i).Value
              tab1(4, 1) = sh.Range("al" & i).Value
              tab1(5, 1) = sh.Range("ad" & i).Value
              tab1(6, 1) = sh.Range("ae" & i).Value
              tab1(7, 1) = sh.Range("af" & i).Value
              tab1(8, 1) = sh.Range("ag" & i).Value
              tab1(9, 1) = sh.Range("ah" & i).Value
              tab1(10, 1) = sh.Range("ai" & i).Value
              tab1(11, 1) = sh.Range("am" & i).Value
              tab1(12, 1) = sh.Range("an" & i).Value
              tab1(13, 1) = sh.Range("ao" & i).Value
              tab1(14, 1) = sh.Range("ar" & i).Value
              tab1(15, 1) = sh.Range("as" & i).Value
              tab1(16, 1) = sh.Range("at" & i).Value
              tab1(17, 1) = sh.Range("ak" & i).Value
              tab1(18, 1) = sh.Range("aj" & i).Value
              tab1(19, 1) = sh.Range("m" & i).Value
              Worksheets("FB Fully Redeemed").Select
              Range(Cells(k, 1), Cells(k, 19)).Value = Application.Transpose(tab1)
             k = k + 1
 
            End If
        Next i
    i = i + 1
 
End Sub

cordialement

21/11/2007, 14h22
derech

Tout fonctionne!
Merci Beaucoup à vous deux pour votre temps!

Le gagnant est Fred ;):king:

Voir 40 message(s) de cette discussion en une page