Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 12 PS5 Disney+ Orange Livebox Windows 11 ChatGPT
Entraide Applications Microsoft Office Excel Recopie de colonne

Recopie de colonne

3 réponses
Avatar
Mireille qui craque
Bjr,
J'ai un probleme sur lequel je bute (et je suis polie)=20
depuis hier.
A partir d'une feuille ou j'ai genere des sous-totaux je=20
veux pour chaque ligne sous totale generer un tableau en=20
colonne. Pb je ne connais pas le nombre de rupture. Donc=20
j'ai imagin=E9 queje pouvais creer 3 colonnes en les=20
recopiant.
Le resultat du script ci-dessous donne rien en terme de=20
recopie, les formules ne sont pas reconduites !!!
Help me avant que je saute par la fenetre (je suis au=20
1er ...)
Merci

Wi =3D 1
WNAg =3D 5
On Err GoTo Terr
With Ws
Do Until Left(.Cells(Wi, 1), 5) =3D "Total"
If Left(.Cells(Wi, 2), 5) =3D "Somme" Then
WNAg =3D WNAg + 3
Workbooks("doc17.xls").Sheets("Agences").Activate
Workbooks("doc17.xls").Sheets("Agences").Range
("E1:G17").Select
'Application.CutCopyMode =3D False
Workbooks("doc17.xls").Sheets
("Agences").Selection.Copy
Workbooks("doc17.xls").Sheets("Agences").Range
(Cells(17, WNAg + 2), Cells(1, WNAg)).Select
ActiveSheet.Paste
Application.CutCopyMode =3D False
WLen =3D Len(.Cells(Wi, 2))
WlAg =3D Right(.Cells(Wi, 2), WLen - 6)
Workbooks("doc17.xls").Sheets("Agences").Cells(1,=20
WNAg) =3D WlAg
=20
Wr =3D WNAg
WSi =3D Wi
'Debug.Print Workbooks("doc17.xls").Sheets
("Agences").ActiveCell.Name
Charg
End If
If Left(.Cells(Wi, 1), 5) =3D "Somme" Then
Wr =3D 5
WSi =3D Wi
Charg
End If
Wi =3D Wi + 1
Loop
=20
End With
Signaler un problème avec ce contenu

3 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
Lydya
Bonjour Mireille,
Il ne faut pas craquer ;-)
AV a posté il y a quelques jours ce code qui récupère les lignes des
sous-totaux (Merci AV !)...
--
Sub Sous_Ttx()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Dim plg As Range
Set plg = Range("A2:D" & [A65536].End(3).Row -
1).SpecialCells(xlCellTypeConstants, 23). _
SpecialCells(xlCellTypeVisible)
For Each c In plg
Cells(c.Row, "E") = "fifi"
Next
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub
--
Il suffit, dans ton cas, de modifier la boucle For Each... et d'y ajouter le
"copier / collage special: valeurs, transposé" pour copier/coller toutes les
lignes des sous-totaux transposées en colonnes, par exemple sur une deuxième
feuille (Range à adapter en fonction de tes données) :
--
Sub Sous_TtxAvecCopie()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Dim plg As Range
Dim col As Integer
Dim c As Range
Set plg = Range("A2:D" & [A65536].End(3).Row - 1) _
.SpecialCells(xlCellTypeConstants, 23). _
SpecialCells(xlCellTypeVisible)
col = 1
For Each c In plg
Range(Cells(c.Row, "A"), Cells(c.Row, "D")).Copy
Sheets(2).Cells(1, col).PasteSpecial Paste:=xlValues, Transpose:=True
col = col + 1
Next
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub
--
Bonne journée !
Lydya


"Mireille qui craque" a écrit dans le
message de news:06eb01c39474$bf9d9a80$
Bjr,
J'ai un probleme sur lequel je bute (et je suis polie)
depuis hier.
A partir d'une feuille ou j'ai genere des sous-totaux je
veux pour chaque ligne sous totale generer un tableau en
colonne. Pb je ne connais pas le nombre de rupture. Donc
j'ai imaginé queje pouvais creer 3 colonnes en les
recopiant.
Le resultat du script ci-dessous donne rien en terme de
recopie, les formules ne sont pas reconduites !!!
Help me avant que je saute par la fenetre (je suis au
1er ...)
Merci

Wi = 1
WNAg = 5
On Err GoTo Terr
With Ws
Do Until Left(.Cells(Wi, 1), 5) = "Total"
If Left(.Cells(Wi, 2), 5) = "Somme" Then
WNAg = WNAg + 3
Workbooks("doc17.xls").Sheets("Agences").Activate
Workbooks("doc17.xls").Sheets("Agences").Range
("E1:G17").Select
'Application.CutCopyMode = False
Workbooks("doc17.xls").Sheets
("Agences").Selection.Copy
Workbooks("doc17.xls").Sheets("Agences").Range
(Cells(17, WNAg + 2), Cells(1, WNAg)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
WLen = Len(.Cells(Wi, 2))
WlAg = Right(.Cells(Wi, 2), WLen - 6)
Workbooks("doc17.xls").Sheets("Agences").Cells(1,
WNAg) = WlAg

Wr = WNAg
WSi = Wi
'Debug.Print Workbooks("doc17.xls").Sheets
("Agences").ActiveCell.Name
Charg
End If
If Left(.Cells(Wi, 1), 5) = "Somme" Then
Wr = 5
WSi = Wi
Charg
End If
Wi = Wi + 1
Loop

End With
Avatar
Mireille qui NE craque plus
Merci pour ton aide
-----Message d'origine-----
Bonjour Mireille,
Il ne faut pas craquer ;-)
AV a posté il y a quelques jours ce code qui récupère les
lignes des

sous-totaux (Merci AV !)...
--
Sub Sous_Ttx()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Dim plg As Range
Set plg = Range("A2:D" & [A65536].End(3).Row -
1).SpecialCells(xlCellTypeConstants, 23). _
SpecialCells(xlCellTypeVisible)
For Each c In plg
Cells(c.Row, "E") = "fifi"
Next
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub
--
Il suffit, dans ton cas, de modifier la boucle For
Each... et d'y ajouter le

"copier / collage special: valeurs, transposé" pour
copier/coller toutes les

lignes des sous-totaux transposées en colonnes, par
exemple sur une deuxième

feuille (Range à adapter en fonction de tes données) :
--
Sub Sous_TtxAvecCopie()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Dim plg As Range
Dim col As Integer
Dim c As Range
Set plg = Range("A2:D" & [A65536].End(3).Row - 1) _
.SpecialCells(xlCellTypeConstants, 23). _
SpecialCells(xlCellTypeVisible)
col = 1
For Each c In plg
Range(Cells(c.Row, "A"), Cells(c.Row, "D")).Copy
Sheets(2).Cells(1, col).PasteSpecial Paste:=xlValues,
Transpose:=True

col = col + 1
Next
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub
--
Bonne journée !
Lydya


"Mireille qui craque"
a écrit dans le

message de news:06eb01c39474$bf9d9a80$
Bjr,
J'ai un probleme sur lequel je bute (et je suis polie)
depuis hier.
A partir d'une feuille ou j'ai genere des sous-totaux je
veux pour chaque ligne sous totale generer un tableau en
colonne. Pb je ne connais pas le nombre de rupture. Donc
j'ai imaginé queje pouvais creer 3 colonnes en les
recopiant.
Le resultat du script ci-dessous donne rien en terme de
recopie, les formules ne sont pas reconduites !!!
Help me avant que je saute par la fenetre (je suis au
1er ...)
Merci

Wi = 1
WNAg = 5
On Err GoTo Terr
With Ws
Do Until Left(.Cells(Wi, 1), 5) = "Total"
If Left(.Cells(Wi, 2), 5) = "Somme" Then
WNAg = WNAg + 3
Workbooks("doc17.xls").Sheets("Agences").Activate
Workbooks("doc17.xls").Sheets("Agences").Range
("E1:G17").Select
'Application.CutCopyMode = False
Workbooks("doc17.xls").Sheets
("Agences").Selection.Copy
Workbooks("doc17.xls").Sheets("Agences").Range
(Cells(17, WNAg + 2), Cells(1, WNAg)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
WLen = Len(.Cells(Wi, 2))
WlAg = Right(.Cells(Wi, 2), WLen - 6)
Workbooks("doc17.xls").Sheets("Agences").Cells(1,
WNAg) = WlAg

Wr = WNAg
WSi = Wi
'Debug.Print Workbooks("doc17.xls").Sheets
("Agences").ActiveCell.Name
Charg
End If
If Left(.Cells(Wi, 1), 5) = "Somme" Then
Wr = 5
WSi = Wi
Charg
End If
Wi = Wi + 1
Loop

End With


.



Avatar
Ellimac
Bonjour,

La macro suivante récupère les sous totaux en colonne A et
recopie le libellé de la colonne A et la valeur calculée
et va coller à partir de la colonne G :

Sub Toto()
nb = Application.CountIf(Range(Range("a1"), _
Range("a1").End(xlDown)), "Somme*")
Range("a1").Select
For cpt = 1 To nb
Range(ActiveCell, ActiveCell.End(xlDown)).Find
("Somme", LookIn:=xlValues).Activate
ActiveCell.Copy Range("g1").Offset(0, cpt - 1)
ActiveCell.End(xlToRight).Copy
a = ActiveCell.Address
Range("g1").Offset(1, cpt - 1).PasteSpecial
xlPasteValues
Range(a).Select
Next
End Sub

Camille

-----Message d'origine-----
Bjr,
J'ai un probleme sur lequel je bute (et je suis polie)
depuis hier.
A partir d'une feuille ou j'ai genere des sous-totaux je
veux pour chaque ligne sous totale generer un tableau en
colonne. Pb je ne connais pas le nombre de rupture. Donc
j'ai imaginé queje pouvais creer 3 colonnes en les
recopiant.
Le resultat du script ci-dessous donne rien en terme de
recopie, les formules ne sont pas reconduites !!!
Help me avant que je saute par la fenetre (je suis au
1er ...)
Merci

Wi = 1
WNAg = 5
On Err GoTo Terr
With Ws
Do Until Left(.Cells(Wi, 1), 5) = "Total"
If Left(.Cells(Wi, 2), 5) = "Somme" Then
WNAg = WNAg + 3
Workbooks("doc17.xls").Sheets("Agences").Activate
Workbooks("doc17.xls").Sheets("Agences").Range
("E1:G17").Select
'Application.CutCopyMode = False
Workbooks("doc17.xls").Sheets
("Agences").Selection.Copy
Workbooks("doc17.xls").Sheets("Agences").Range
(Cells(17, WNAg + 2), Cells(1, WNAg)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
WLen = Len(.Cells(Wi, 2))
WlAg = Right(.Cells(Wi, 2), WLen - 6)
Workbooks("doc17.xls").Sheets("Agences").Cells(1,
WNAg) = WlAg

Wr = WNAg
WSi = Wi
'Debug.Print Workbooks("doc17.xls").Sheets
("Agences").ActiveCell.Name
Charg
End If
If Left(.Cells(Wi, 1), 5) = "Somme" Then
Wr = 5
WSi = Wi
Charg
End If
Wi = Wi + 1
Loop

End With
.