Microsoft 365 Transformer un code

  • Initiateur de la discussion Initiateur de la discussion lucarn
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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
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
 
heu.. dis moi un peu, je peux LOL tout de suite ou tu va le prendre mal ?

ton sheets rapport a des cellules deja formatées en url
c'est normal que tu est ce que tu envoie comme étant des liens

bon maintenant je m'en fou je LOL

HAHAHIHIHAHAHA 😀 😀 😀 😀 😉
regarde ce que je fait au début je ne delete pas je clear !!!

VB:
Sub Transposerficheaction()
    Dim f As Worksheet
    With Sheets("RAPPORTS").Cells(3, 1).Resize(Sheets("RAPPORTS").UsedRange.Rows.Count, 54): .Clear: End With 'clear!!clear!!!clear!!!clear!!!!!
    For Each f In Sheets
        If Left(f.Name, 1) = "F" Then
            With Sheets("RAPPORTS").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

remet le bon nom de sheets quand tu aura tester
 
Tu peux y aller. Je suis tellement nul en macro...
Le problème, c'est que ta dernière macro ne correspond pas du tout à ma demande.
C'est une macro qui transpose alors que je veux un collé normal en ligne de ce qui se trouve entre les colonnes 15 à 21 et les lignes 1 à 8 comme dans le doc en lien.

J'ai mis dans l'onglet RAPPORTS d'abord ce que je veux et ensuite ce que ta macro m'a donné
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
7
Affichages
166
Réponses
3
Affichages
671
Réponses
16
Affichages
1 K
Réponses
35
Affichages
2 K
Réponses
2
Affichages
406
Réponses
5
Affichages
480
Retour