Microsoft 365 Transformer un code

lucarn

XLDnaute Occasionnel
Bonjour,
Je n'y connais et j'essaye.
J'ai cette macro qui fonctionne

Sub Transposerficheaction()
With Sheets("TRANSPOSE")
.Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 54)).Delete
End With
nf = 0
For Each f In Sheets
If Left(f.Name, 1) = "F" Then
Set zone = f.Range(f.Cells(1, 1), f.Cells(54, 7))
Call col(zone, nf)
nf = nf + 1

End If

Next
End Sub

Sub col(zone, nf)
With Sheets("TRANSPOSE")
zone.Parent.Activate
zone.Copy
.Cells(nf * 8 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True


End With
End Sub


C'est une macro d'une transposition des colonnes 1 à 7 de la ligne 1 à 54.

Je tente vainement de lui faire faire une opération similaire à partir de la colonne 15 jusqu'à la 21, et de la ligne 1 à 8

Je dois dire que je suis assez furax de n'avoir pas réussi.
Si vous pouviez me calmer, ce serait gentil
 
Solution
Re,

Essayez:
VB:
Sub Transposerficheaction()
With Sheets("TRANSPOSE")
    .Cells(3, 1).Resize(.UsedRange.Rows.Count, 8).Clear
    nf = 0
    For Each f In Sheets
        If Left(f.Name, 1) = "F" Then
            f.Range(f.Cells(1, 15), f.Cells(8, 21)).Copy
            .Cells(nf * 8 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            nf = nf + 1
        End If
    Next f
End With
End Sub

mapomme

XLDnaute Barbatruc
Supporter XLD
Re,

Essayez:
VB:
Sub Transposerficheaction()
With Sheets("TRANSPOSE")
    .Cells(3, 1).Resize(.UsedRange.Rows.Count, 8).Clear
    nf = 0
    For Each f In Sheets
        If Left(f.Name, 1) = "F" Then
            f.Range(f.Cells(1, 15), f.Cells(8, 21)).Copy
            .Cells(nf * 8 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            nf = nf + 1
        End If
    Next f
End With
End Sub
 

lucarn

XLDnaute Occasionnel
Re,

Essayez:
VB:
Sub Transposerficheaction()
With Sheets("TRANSPOSE")
    .Cells(3, 1).Resize(.UsedRange.Rows.Count, 8).Clear
    nf = 0
    For Each f In Sheets
        If Left(f.Name, 1) = "F" Then
            f.Range(f.Cells(1, 15), f.Cells(8, 21)).Copy
            .Cells(nf * 8 + 3, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            nf = nf + 1
        End If
    Next f
End With
End Sub
Bonjour Mapomme,
Merci pour le coup de main. Ca marche.
J'en profite pour te demander autre chose en partant du même code.
Je voudrais rassembler dans un onglet, une partie d'un formulaire en copié/collé sans transposition.
A partir du code que tu m'as donné, peux-tu apporté les modifs pour un copié/collé classique ?
Je m'en débrouillerai pour créer le code exact dont j'ai besoin
Bonne journée
 

patricktoulon

XLDnaute Barbatruc
bonjour le fil
peut être sans paste ;)
VB:
Sub Transposerficheaction()
    Dim f As Worksheet
    Sheets("TRANSPOSE").Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 54)).Delete
    For Each f In Sheets
        If Left(f.Name, 1) = "F" Then
            With Sheets("TRANSPOSE").Cells(Rows.Count, 1).End(xlUp).Offset(1).resize(7,54)
                .Value = Application.Transpose(f.Cells(1).Resize(54, 7).Value)
            End With
        End If
    Next
End Sub
 
Dernière édition:

lucarn

XLDnaute Occasionnel
bonjour le fil
peut être sans paste ;)
VB:
Sub Transposerficheaction()
    Dim f As Worksheet
    Sheets("TRANSPOSE").Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 54)).Delete
    For Each f In Sheets
        If Left(f.Name, 1) = "F" Then
            With Sheets("TRANSPOSE").Cells(Rows.Count, 1).End(xlUp).Offset(1).resize(7,54)
                .Value = Application.Transpose(f.Cells(1).Resize(54, 7).Value)
            End With
        End If
    Next
End Sub
BonPatrick,
Merci.
Mais ça ne marche pas. Voici la capture
Et lorsque je repars de ma macro et que j'enlève tout ce qu'il a après False, ça donne l'autre capture
1584109673256.png

1584109930864.png
 

lucarn

XLDnaute Occasionnel
bonjour le fil
peut être sans paste ;)
VB:
Sub Transposerficheaction()
    Dim f As Worksheet
    Sheets("TRANSPOSE").Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 54)).Delete
    For Each f In Sheets
        If Left(f.Name, 1) = "F" Then
            With Sheets("TRANSPOSE").Cells(Rows.Count, 1).End(xlUp).Offset(1).resize(7,54)
                .Value = Application.Transpose(f.Cells(1).Resize(54, 7).Value)
            End With
        End If
    Next
End Sub
Je voulais dire Paste
 

patricktoulon

XLDnaute Barbatruc
re
VB:
Sub Transposerficheaction()
    Dim f As Worksheet
    With Sheets("TRANSPOSE"): .Cells(3, 1).Resize(.UsedRange.Rows.Count, 54).Delete: End With
    For Each f In Sheets
        If Left(f.Name, 1) = "F" Then
            With Sheets("TRANSPOSE").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(7, 54)
                .Value = Application.Transpose(f.Cells(1).Resize(54, 7).Value)
            End With
        End If
    Next
End Sub
 

lucarn

XLDnaute Occasionnel
Oui, j'ai les 7 lignes vides.
Mais, mon problème, c'est que les cellules que je dois copier sont entre la 15e et la 21e colonne et la 1ere et 8e ligne. Je ne sais pas comment remettre ces paramètres dans ton code. Et puis, petite précision parce que le code de départ sur lequel tu m'aides est fait pour un collé transposé. Mais, le second problème auquel tu réponds, c'est pour coller sans transposition.
 

patricktoulon

XLDnaute Barbatruc
Oui, j'ai les 7 lignes vides.
Mais, mon problème, c'est que les cellules que je dois copier sont entre la 15e et la 21e colonne et la 1ere et 8e ligne. Je ne sais pas comment remettre ces paramètres dans ton code. Et puis, petite précision parce que le code de départ sur lequel tu m'aides est fait pour un collé transposé. Mais, le second problème auquel tu réponds, c'est pour coller sans transposition.


With Sheets("TRANSPOSE").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(8, 7)
.Value = Application.Transpose(f.Cells(1,15).Resize(8, 7).Value)
End With
 

lucarn

XLDnaute Occasionnel
Salut Patrick,
C'est presque bon. Je n'ai plus de lignes vides.
Mais ça n'est pourtant pas ça.
Le mieux est que je te mette en lien, le doc sur lequel je travaille.
Il faut remplir l'onglet RAPPORTS par ce qui se trouve entre la 15e et la 21e colonne et la 1ere et 8e ligne des onglets F. J'ai mis le résultat souhaité dans l'onglet RAPPORTS.
Désolé de t'embêter une nouvelle fois.
 

Pièces jointes

  • Fiches action MODELE.xlsm
    444.5 KB · Affichages: 5

patricktoulon

XLDnaute Barbatruc
re
bonjour
heu chez moi c'est bon du moins je crois
il y a des hauteur de lignes qui sont grande parce qu'il y a beaucoup de texte mais sinon c'est ca
je les un peu plus espacé et encdrée en rouge pour mieux voir
VB:
Sub Transposerficheaction()
    Dim f As Worksheet
    With Sheets("TRANSPOSE").Cells(3, 1).Resize(Sheets("TRANSPOSE").UsedRange.Rows.Count, 54): .Clear: End With
    For Each f In Sheets
        If Left(f.Name, 1) = "F" And f.Name <> "F1" Then
            With Sheets("TRANSPOSE").Cells(Rows.Count, 1).End(xlUp).Offset(4).Resize(7, 54)
                .BorderAround Color:=vbRed, Weight:=xlThick
                .WrapText = False
                .Value = Application.Transpose(f.Cells(1).Resize(54, 7).Value)
            End With
        End If
    Next
End Sub
après tu a des fusionnées peut être que c'est ça le problème
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 947
Membres
101 849
dernier inscrit
florentMIG