Transposition complexe

  • Initiateur de la discussion Initiateur de la discussion Pete
  • 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 !

Pete

XLDnaute Nouveau
Bonjour à toutes et à tous.

Je me tourne vers vous car j'ai un problème difficile à résoudre. En soit, j'ai déjà une solution mais qui est applicable à petite échelle. En utilisant ma technique il me faudrait 10 ans pour tout faire. Bref, voilà mon problème:

J'ai une liste d'établissements sur un document au fichier (RTF, c'est comme DOC en quelque sorte) qui contient le nom + l'adresse + le courriel + les formations proposées.

Exemple:
01 Ambérieu-en-Bugey
CFA CECOF
52 avenue de la Libération BP 209 01502 Ambérieu-en-Bugey Cedex
Tél. : 04 74 38 40 22 Fax : 04 74 38 41 02 Courriel : cfa@cecof.asso.fr
Site Web : CECOF C.F.A.
(CFA privé - Internat garçons-filles - Plan de classement : RES 8050)
BTM Pâtissier confiseur glacier traiteur (apprentissage - 2 ans)


02 Laon
CFA de la Chambre de métiers et de l'artisanat
30 rue d'Enfer 02000 Laon
Tél. : 03 23 23 16 70 Fax : 03 23 79 62 26 Courriel : laon.cfa@cma-aisne.fr
Site Web : L' apprentissage à Laon, La Capelle et Château-Thierry - Artisanat, Aisne (Picardie)
(Consulaire - Internat garçons-filles - Plan de classement : RES 8036)
BTM Pâtissier confiseur glacier traiteur (apprentissage - 2 ans)


04 Digne-les-Bains
CFA de la Chambre de métiers René Villeneuve
15 rue Maldonat 04000 Digne-les-Bains
Tél. : 04 92 30 90 80 Fax : 04 92 30 90 81 Courriel : cfa.digne@cm-04.fr
Site Web : de1182.ispfr.net/
(Consulaire - Internat garçons-filles - Plan de classement : RES 8035 01)
BTM Pâtissier confiseur glacier traiteur (apprentissage - 2 ans)

Comme vous pouvez le constater, le chiffre correspond au département, puis la ville, en dessous les diverses données.

Je dois rentrer ce fichier sur excel (copier coller) puis lorsque c'est fait, je dois déplacer tous les groupes et les mettre côte à côte ( et non à la suite comme ci dessus) pour pouvoir les transposer et obtenir ces données sous le format suivant (voir pièce jointe).

Le truc, c'est que je n'ai pas que 3 groupes comme ci dessus mais des dizaines de milliers mais ma technique prend du temps.
Avez-vous une idée/solution?

Merci encore de votre aide
 

Pièces jointes

Re : Transposition complexe

Merci de votre réponse aussi rapide.

Alors j'ai rajouté d'autres données sur l'onglet 1 et lorsque je sélectionne de A2:H2 et que je tires... ça ne marche pas... enfin du moins, tout change et se perd...
 
Re : Transposition complexe

Oups edit: Salut Laurent 🙂

avec ce code

Code:
Option Explicit
Sub transpose()
Dim FSource, FDestination As Worksheet
Dim NbLignes, i, Max As Long


Set FSource = Sheets("Etape 1")
Set FDestination = Sheets("Résult")

NbLignes = FSource.UsedRange.Rows.Count
Max = FDestination.Range("A:A").Rows.Count
For i = 1 To NbLignes Step 8
    FDestination.Range("A" & Max).End(xlUp).Offset(1, 0) = FSource.Range("A" & i)
    FDestination.Range("B" & Max).End(xlUp).Offset(1, 0) = FSource.Range("B" & i)
    FDestination.Range("C" & Max).End(xlUp).Offset(1, 0) = FSource.Range("B" & i + 1)
    FDestination.Range("D" & Max).End(xlUp).Offset(1, 0) = FSource.Range("B" & i + 2)
    FDestination.Range("E" & Max).End(xlUp).Offset(1, 0) = FSource.Range("C" & i + 3)
    FDestination.Range("F" & Max).End(xlUp).Offset(1, 0) = FSource.Range("C" & i + 4)
    FDestination.Range("G" & Max).End(xlUp).Offset(1, 0) = FSource.Range("C" & i + 5)
    FDestination.Range("H" & Max).End(xlUp).Offset(1, 0) = FSource.Range("C" & i + 6)

Next i
End Sub
 
Re : Transposition complexe

Bonsoir à tous, 🙂

Une autre solution :
VB:
Option Explicit

Sub test()
Dim myAreas As Areas, myArea As Range, b(), n As Long
    Application.ScreenUpdating = False
    On Error Resume Next
    Set myAreas = Sheets(1).Columns(1).SpecialCells(2).Areas
    On Error GoTo 0
    If myAreas Is Nothing Then Exit Sub
    ReDim b(1 To myAreas.Count + 1, 1 To 8)
    b(1, 1) = "Département": b(1, 2) = "Ville"
    b(1, 3) = "Etablissement": b(1, 4) = "Adresse/autre"
    b(1, 5) = "Tel": b(1, 6) = "URL"
    b(1, 7) = "Statut": b(1, 8) = "Intitulé"
    n = 1
    For Each myArea In myAreas
        n = n + 1
        b(n, 1) = myArea(1, 1): b(n, 2) = myArea(1, 2)
        b(n, 3) = myArea(2, 2): b(n, 4) = myArea(3, 2)
        b(n, 5) = myArea(4, 3): b(n, 6) = myArea(5, 3)
        b(n, 7) = myArea(6, 3): b(n, 8) = myArea(7, 3)
    Next
    With Sheets(2).Cells(1).Resize(UBound(b, 1), UBound(b, 2))
        .Value = b
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .BorderAround Weight:=xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        With .Rows(1)
            .BorderAround Weight:=xlThin
            .Interior.ColorIndex = 44
        End With
        .Columns.AutoFit
        .Parent.Activate
    End With
    Set myAreas = Nothing
    Application.ScreenUpdating = True
End Sub
klin89
 
Dernière édition:
Re : Transposition complexe

Re Pete, 🙂

Avec le fichier du post #9 et suite à la remarque de phlaurent55.

VB:
Option Explicit

Sub test()
Dim myAreas As Areas, myArea As Range, LastR As Long
    Application.ScreenUpdating = False
    On Error Resume Next
    Set myAreas = Sheets(1).Columns(2).SpecialCells(2).Areas
    'Sheets(1).Columns(2).SpecialCells(2).Select
    On Error GoTo 0
    If myAreas Is Nothing Then Exit Sub
    'Restitution
    With Sheets(3)
        LastR = .Cells(.Rows.Count, 3).End(xlUp).Row
        For Each myArea In myAreas
            If myArea.Rows.Count = 3 Then
                If Not IsEmpty(myArea.Cells(1, 0)) Then
                    myArea.CurrentRegion.Columns(3).Copy
                    .Cells(LastR, 2).PasteSpecial Transpose:=True
                    .Cells(LastR, 1).Value = myArea.Cells(1, 0).Value
                Else
                    myArea.CurrentRegion.Columns(2).Copy
                    .Cells(LastR, 2).PasteSpecial Transpose:=True
                End If
                myArea.Copy
                .Cells(LastR, 2).PasteSpecial Transpose:=True
            End If
            If myArea.Rows.Count = 2 Then
                myArea.CurrentRegion.Columns(2).Copy
                .Cells(LastR, 3).PasteSpecial Transpose:=True
                myArea.Copy
                .Cells(LastR, 3).PasteSpecial Transpose:=True
            End If
            LastR = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
        Next
        'Mise en forme
        With .Cells(1).CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Columns.AutoFit
            .Parent.Activate
        End With
    End With
    Set myAreas = Nothing
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
End Sub
klin89
 
- 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
Retour