Transposition complexe

[Pete]

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

 

[vgendron]

Re : Transposition complexe

Bonjour

Ci joint un test avec formules: Plusieurs formules dans la ligne jaune
tu sélectionnes de A2:H2
et tu tires vers le bas..

ensuite.. un copier coller valeur..

sinon, il va y avoir la solution VBA

 

[phlaurent55]

Re : Transposition complexe

Bonjour à tous,

une solution par macro

à+
Philippe

 

[Pete]

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...

 

[Pete]

Re : Transposition complexe

Phlaurent55, merci de votre réponse.

Votre macro semble bien marcher... Si je rajoute des données sur l'étape 1 (onglet 1), elles seront prisent en compte sur l'onglet Résultat?

 

[vgendron]

Re : Transposition complexe

Oups edit: Salut Laurent

avec ce 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

 

[Pete]

Re : Transposition complexe

Mhhh, je dois sûrement me tromper quelque part mais la macro ou le code ne marche pas pour cette liste...
Et je n'arrive pas à comprendre la raison

 

[gosselien]

Re : Transposition complexe

Bonjour,

la macro utilise 2 onglets , les tiens ont ils les mêmes noms ?

P.

 

[Pete]

Re : Transposition complexe

Bonsoir, Alors oui j'ai bien les deux bons noms sur les onglets mais le résultat est étrange...

 

[klin89]

Re : Transposition complexe

Bonsoir à tous,

Une autre solution :

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

 

[phlaurent55]

Re : Transposition complexe

Re,

Bonsoir, Alors oui j'ai bien les deux bons noms sur les onglets mais le résultat est étrange...

L'étrangeté vient du fait que les paquets de données à répartir se trouvent parfois sur 7 lignes mais ce n'est pas toujours les cas

à+
Philippe

 

[klin89]

Re : Transposition complexe

Re Pete,

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

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