Microsoft 365 Transformer un code

lucarn · 12 Mars 2020

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

mapomme · 12 Mars 2020

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 · 17 Mars 2020

patricktoulon à dit:
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

lucarn · 17 Mars 2020

Je ne comprends pas si chez toi ça fonctionne. Parce que chez moi, ça donne ça

patricktoulon · 17 Mars 2020

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

lucarn · 17 Mars 2020

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é

Microsoft 365 Transformer un code

lucarn

XLDnaute Occasionnel

mapomme

lucarn

XLDnaute Occasionnel

lucarn

XLDnaute Occasionnel

Pièces jointes

patricktoulon

XLDnaute Barbatruc

lucarn

XLDnaute Occasionnel

Pièces jointes

Discussions similaires