Comment transposer des colonnes en lignes en VBA?

Version imprimable

11/08/2009, 15h13
franckimmo

Comment transposer des colonnes en lignes en VBA?

:cry: Bonjour à tous, :cry:

Mon problème est que dans mon fichier exell, j'ai rempli les infos pour le client, puis tous les mois je créer deux colonnes une pour le montant versé par le client et l'autre par le numéro d'extrait de compte référencent le paiement du client. Le problème c'est que dans une année et bien je crée 24 colonnes supplémentaire.
J'aimerai transférer toutes ces colonnes en lignes afin de pouvoir les transférer dans access.
La colonne C indique le ID du client
Ex de mon souhait:
1er Ligne Colonne A à I et colonne J + colonne K
2ème Ligne Colonne A à I et Colonne L + colonne M
Etc....
Je pense qu'aucune solutio est envisageable, mais peut être que je me trompe
Merci bien
Ci-joint le fichier exell

Bonjour,
Voici un petit code exemple pour te mettre sur la piste...bon amusement ;)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub PrepaAccess()
 
Dim DerLtabl As Long, derLigne As Long, NbCol As Long, i As Long
 
DerLtabl = Cells(Range("A:A").Rows.Count, 1).End(xlUp).Row 'détermine la derière ligne pour la sélection à copier
NbCol = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column 'détermine le nombre de colonne
 
For i = 11 To NbCol Step 2 'fait une boucle pour balayer les colonnes
    derLigne = Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1 'défini la dernière ligne de la colonne i pour le collage
    Range(Cells(2, 1), Cells(DerLtabl, 8)).Copy Destination:=Cells(derLigne, 1)
    Range(Cells(2, i), Cells(DerLtabl, i + 1)).Copy Destination:=Cells(derLigne, 9)
Next i
 
End Sub

A+

11/08/2009, 16h55
franckimmo

Bonjour Fvandermeulen,

Merci pour ton aide, dans l'exemple je souhaiterai plutôt créer une autre feuille. La colonne B étant L'Id de chaque client et la colonne D le nom de chaque client.
La colonne I le montant versé d'un certain mois, la colonne J le numéro de l'extrait de paiement et la colonne K le mois et l'année du versement.
La colonne L le montant versé du mois suivant, la colonne M le numéro de l'extrait de paiement du mois suivant et la colonne N le mois et l'année du versement du mois suivant.
En règle général l'idéal serait :
Ligne1 B+D+I+J+K
Ligne2 B+D+L+M+N
Merci bien

Salut,
L'idée c'était que tu cherche un peu ;)
Tu pouvais copier ta feuille faire tourner le code et ensuite faire un tri sur le numéro ID, je pense que tu aurais le même résultat, mais pour le sport, voici le code adapté avec une boucle suplémentaire pour les lignes.
J'ai ajouter une feuille manuellement (feuille nommée Cible)
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Sub PrepaAcces2() Dim DerLtabl As Long, derLigne As Long, NbCol As Long, i As Long, j As Long DerLtabl = Cells(Range("A:A").Rows.Count, 1).End(xlUp).Row NbCol = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column For j = 2 To DerLtabl For i = 9 To NbCol Step 2 derLigne = Sheets("Cible").Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1 Range(Cells(j, 1), Cells(j, 8)).Copy Destination:=Sheets("Cible").Cells(derLigne, 1) Range(Cells(j, i), Cells(j, i + 1)).Copy Destination:=Sheets("Cible").Cells(derLigne, 9) Next i Next j End Sub
A+

Bonjour Fvandermeulen,

J'ai un peu changé ton code, mais le premier problème je n'ai plus le titre. Le deuxième c'est si les colonne I ou J vide ou les deux alors ne pas copier la ligne est-ce possible cela.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
   Sub PrepaAcces2()
 
Dim DerLtabl As Long, derLigne As Long, NbCol As Long, i As Long, j As Long
 
DerLtabl = Cells(Range("A:A").Rows.Count, 1).End(xlUp).Row
NbCol = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column
 
For j = 2 To DerLtabl
    For i = 10 To NbCol Step 3
        derLigne = Sheets("Cible").Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1
        Range(Cells(j, 1), Cells(j, 8)).Copy Destination:=Sheets("Cible").Cells(derLigne, 1)
        Range(Cells(j, i), Cells(j, i + 1)).Copy Destination:=Sheets("Cible").Cells(derLigne, 9)
    Next i
Next j
 
End Sub

La seule chose que j'ai trouvé pour la création des libellés c'est ceux-ci :

Code:

1
2
3
4
5
Range("A1:N1").Select
    Selection.Copy
    Sheets("Cible").Select
    Rows("1:1").Select
    ActiveSheet.Paste

Mais franchement j'aime pas trop, cela fait pas pro.

Merci bien

:cry: Bonjour à tous, :cry:

J'aimerai mettre trois colonnes (i,j et k) en ligne. Avec le code ci-dessous je n'arrive qu'a en mettre deux (i et j) comment faire pour mettre la colonne k en ligne? Je n'arrive pas à trouver la syntaxe.
Le deuxième problème que je rencontre c'est que tous le tableau se met en gras et non que la première ligne (a1:k1)
Si quelqu'un a une idée ce serait sympa.
Merci à vous

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
Sub PrepaAcces2()
 
Dim DerLtabl As Long, derLigne As Long, NbCol As Long, i As Long, j As Long
 
DerLtabl = Cells(Range("A:A").Rows.Count, 1).End(xlUp).Row 'détermine la derière ligne pour la sélection à copier
 
NbCol = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column 'détermine le nombre de colonne
 
 
 
For j = 2 To DerLtabl
    For i = 10 To NbCol Step 3 'fait une boucle pour balayer les colonnes
 
             'défini la dernière ligne de la colonne i pour le collage
        derLigne = Sheets("Cible").Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1
         Range(Cells(j, 1), Cells(j, 8)).Copy Destination:=Sheets("Cible").Cells(derLigne, 1)
        Range(Cells(j, i), Cells(j, i + 1)).Copy Destination:=Sheets("Cible").Cells(derLigne, 9)
    Next i
Next j
 
 
 Sheets("Cible").Select
With Worksheets("Cible")
    .Cells(1, 1).Value = "Studio"
    .Cells(1, 2).Value = "Code Client"
    .Cells(1, 3).Value = "Agence"
    .Cells(1, 4).Value = "Nom"
    .Cells(1, 5).Value = "Caution"
    .Cells(1, 6).Value = "Date entrée"
    .Cells(1, 7).Value = "Date Sortie"
    .Cells(1, 8).Value = "Loyer"
    .Cells(1, 9).Value = "Extrait"
    .Cells(1, 10).Value = "Mois"
    End With
 
    Selection.Font.Bold = True
    Range("I1:j1").Select
    With Selection.Font
        .Color = -11489280
        .TintAndShade = 0
    End With
 
    Selection.Font.Bold = True
    Range("A1:H1").Select
    Selection.Font.Bold = True
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = -1
 
    End With
 
    Range("a1:j1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

Franck :cry:

:ccool: Bonjour, :ccool:
J'ai trouvé les solution aux problèmes ci-dessus, mais je souhaiterai pouvoir éviter de rajouter les lignes quand la colonne "j" est vide.
Voici tout mon 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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Sub PrepaAcces2()
 
Dim DerLtabl As Long, derLigne As Long, NbCol As Long, i As Long, j As Long, k As Long
 
DerLtabl = Cells(Range("A:A").Rows.Count, 1).End(xlUp).Row 'détermine la derière ligne pour la sélection à copier
 
NbCol = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column 'détermine le nombre de colonne
 
 
 
For j = 2 To DerLtabl
    For i = 10 To NbCol Step 3 'fait une boucle pour balayer les colonnes
 
             'défini la dernière ligne de la colonne i pour le collage
        derLigne = Sheets("Cible").Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1
         Range(Cells(j, 1), Cells(j, 9)).Copy Destination:=Sheets("Cible").Cells(derLigne, 1)
        Range(Cells(j, i), Cells(j, i + 1)).Copy Destination:=Sheets("Cible").Cells(derLigne, 10)
    Next i
Next j
 
 
 Sheets("Cible").Select
With Worksheets("Cible")
    .Cells(1, 1).Value = "Studio"
    .Cells(1, 2).Value = "Code Client"
    .Cells(1, 3).Value = "Agence"
    .Cells(1, 4).Value = "Nom"
    .Cells(1, 5).Value = "Caution"
    .Cells(1, 6).Value = "Date entrée"
    .Cells(1, 7).Value = "Date Sortie"
    .Cells(1, 8).Value = "Loyer"
    .Cells(1, 9).Value = "Montant"
    .Cells(1, 10).Value = "Extrait"
    .Cells(1, 11).Value = "Mois"
 
    End With
 
    Selection.Font.Bold = True
    Range("I1:j1").Select
    With Selection.Font
        .Color = -11489280
        .TintAndShade = 0
    End With
 
    Selection.Font.Bold = True
    Range("A1:H1").Select
    Selection.Font.Bold = True
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = -1
 
    End With
 
    Range("a1:k1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

Bonne soirée à tous
A+

12/08/2009, 08h08
Fvandermeulen

Salut,
Ravis que tu aies progressé, pour vérifier si la colonne J est vide on peut utiliser un If, mais ne veux tu pas vérifier les autres colonnes ?
12/08/2009, 11h36
franckimmo

Salut Fvandermeulen,
Non je pense que le "j" simplement serait suffisant. Si ce n'est pas suffisant alors je mettrai en condition une autre colonne.
La question qui me brûle c'est ton "if" tu le mets après les with ou avant? Et puis une autre question car je ne suis pas avare de question. Dans la syntaxe IF en EXELL c'est la même qu'en access ?
Merci pour ta patience
A+
Franck

Salut,
J'ai adapté le code pour que les lignes sans données en "Fol" (donc toutes les colonnes) ne soient pas copiées car j'ai constaté que certaines lignes avaient des données dans d'autres colonnes même si il n'y en avait pas en J. Donc si on se contente de vérifier J tu 'perdras' des données.
Voici le code, tu verras que le If est dans la boucle pour les colonnes.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub PrepaAcces2() Dim DerLtabl As Long, derLigne As Long, NbCol As Long, i As Long, j As Long DerLtabl = Cells(Range("A:A").Rows.Count, 1).End(xlUp).Row NbCol = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column For j = 2 To DerLtabl For i = 9 To NbCol Step 2 If Not IsEmpty(Cells(j, i).Value) Then derLigne = Sheets("Cible").Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1 Range(Cells(j, 1), Cells(j, 8)).Copy Destination:=Sheets("Cible").Cells(derLigne, 1) Range(Cells(j, i), Cells(j, i + 1)).Copy Destination:=Sheets("Cible").Cells(derLigne, 9) Cells(1, i).Copy Destination:=Sheets("Cible").Cells(derLigne, 10) End If Next i Next j End Sub
En ce qui concerne Access, je suis pas aussi à l'aise...mais si tu parles des modules, oui la syntaxe est identique, si c'est dans une requête c'est pas pareil.

A+

12/08/2009, 13h33
franckimmo

:ccool: Salut Fvandermeulen, :ccool:

Super il ne prend pas la ligne J, mais j'ai découvert un petit problème.
La colonne "I", colonne "L" et la colonne "O" sont des colonnes qui indiquent le montant mensuel payé par le client. Parfois le client paye un montant différent par mois, donc j'aimerai indiquer le montant de chaque mois dans mes ligne et non indiquer que la valeur indiquée dans la colonne "I", un peu comme cela ce fait actuellement avec la colonne "J" qui prend la valeur "M" puis "P" dans les lignes suivantes.

As-tu une idée dans la syntaxe à écrire.

Merci bien et bonne après midi
:ccool: Franck :ccool:
12/08/2009, 14h00
Fvandermeulen

Re,
Je m'étais basé sur le fichier que tu avais joint, donc le fichier final est différent...mois j'ai
Colonne I les montant pour aout
Colonne J les reférences pour aout
Colonne K les montant pour sept.
Colonne L les références pour sept.
Et.

Pour changer ça tu dois modifier le step dans la ligne

Code:

For i = 9 To NbCol Step 2

par

Code:

For i = 9 To NbCol Step 3

et aussi la ligne

Code:

Range(Cells(2, i), Cells(DerLtabl, i + 1)).Copy Destination:=Cells(derLigne, 9)

par

Code:

Range(Cells(2, i), Cells(DerLtabl, i + 2)).Copy Destination:=Cells(derLigne, 9)

Je crois que c'est tout mais je ne peux pas tester car je n'ai pas le bon fichier.

A+

:ccool: Salut Fvandermeulen, :ccool:

J'ai rectifié ton code et maintenant tout fonctionne parfaitement. Je te remercie vivement pour tes déductions et ton aide, qui m'ont apportés une compréhension sur la façon d'executer une procédure sous Exell.
Voici le code rectifié, si il peut servir à d'autre ce serait super.

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
Sub PrepaAcces2()
 
Dim DerLtabl As Long, derLigne As Long, NbCol As Long, i As Long, j As Long, k As Long
 
DerLtabl = Cells(Range("A:A").Rows.Count, 1).End(xlUp).Row 'détermine la derière ligne pour la sélection à copier
 
NbCol = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column 'détermine le nombre de colonne
 
 
For j = 2 To DerLtabl
    For i = 9 To NbCol Step 3
        If Not IsEmpty(Cells(j, i).Value) Then
            derLigne = Sheets("Cible").Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1
            Range(Cells(j, 1), Cells(j, 8)).Copy Destination:=Sheets("Cible").Cells(derLigne, 1)
            Range(Cells(j, i), Cells(j, i + 2)).Copy Destination:=Sheets("Cible").Cells(derLigne, 9)
 
        End If
 
    Next i
Next j
 
 Sheets("Cible").Select
With Worksheets("Cible")
    .Cells(1, 1).Value = "Studio"
    .Cells(1, 2).Value = "Code Client"
    .Cells(1, 3).Value = "Agence"
    .Cells(1, 4).Value = "Nom"
    .Cells(1, 5).Value = "Caution"
    .Cells(1, 6).Value = "Date entrée"
    .Cells(1, 7).Value = "Date Sortie"
    .Cells(1, 8).Value = "Loyer"
    .Cells(1, 9).Value = "Montant"
    .Cells(1, 10).Value = "Extrait"
    .Cells(1, 11).Value = "Mois"
 
    End With
 
    Selection.Font.Bold = True
    Range("I1:j1").Select
    With Selection.Font
        .Color = -11489280
        .TintAndShade = 0
    End With
 
    Selection.Font.Bold = True
    Range("A1:H1").Select
    Selection.Font.Bold = True
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = -1
 
    End With
 
    Range("a1:k1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

Trois petites questions : A quoi servent ces trois codes ci-dessous ?

Code:

End(xlUp).Row

Code:

For j = 2 To DerLtabl

Code:

derLigne = Sheets("Cible").Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1

Désolé je n'avait pas vu que tu m'avais répondu .

:ccool: Franck :ccool:

12/08/2009, 14h52
Fvandermeulen

Pour tes trois petites questions...

Code:

End(xlUp).Row

Cette partie correspond, en fait, à faire sur ta feuille Ctrl+flèche haut
Le .row récupère le numéro de ligne.
En général on l'utilise pour définir la dernière ligne remplie en se positionnant d'abord sur la dernière ligne de la feuille (xl2003 = ligne 65536)

Code:

For j = 2 To DerLtabl

Ca c'est un type de boucle, on lui dit que j va de 2 à x
Il incrémentera j de 1 (sauf si on met au step y) jusqu'à arriver x
Dans ton cas on utilise la dernière ligne de ton tableau, donc il ballaie chaque ligne remplie depuis la ligne 2 jusqu'à la fin du tableau.

Code:

derLigne = Sheets("Cible").Cells(Range("I:I").Rows.Count, 1).End(xlUp).Row + 1

Là on défini la ligne sur laquelle on va copier le résultat.
La variable derligne récupère la dernière ligne sur base de la colonne i de la feuille Cible. (voir ta question1)
En fait Range("I:I").rows.count renvoi le nombre de ligne de la feuille (xl2003 = 65536). En l'utilisant avec Cells, on obtient la dernière cellule de ta feuille pour une colonne donnée (dans ce cas la A car ",1")
De là le le "End(xlup)" remonte à la première cellule remplie (donc la dernière du tableau) et le .row récupère le numéro de ligne. Comme on veut copier en dessous on ajoute 1

Voilà j'espère avoir été clair

A+
12/08/2009, 15h03
franckimmo

:lol: Salut, :lol:
Encore une fois merci, car tes explications me seront très utiles pour le futur proche.
Passe une bonne journée et A+
Franck