Données a remettre en place avec une nouvelle presentation

[buzzzer]

Bonjour,
je suis bien perdu avec une base de donnée d'etablisement scolaire qui se presente sur 2 colonnes verticales pour chaque etablisement.J'ai besoin de les remettre sous le format ou j'ai fait un exemple en jaune et j'ai pas la solution le fichiers complet fait a peu pres 150 etablisements donc manuellement c'est tres lourd.

A l'aide!! et merci🙄

 

[Dranreb]

Re : Données a remettre en place avec une nouvelle presentation

Bonjour
Vous pourriez déjà vous alléger le bouleau par une formule du genre:

=DECALER($B$12;0;(LIGNE()-Ligne($A$3)*3)

à mettre en A3, derrière votre modèle pour vérifier. Il ne resterait en effet qu'à la propager vers le bas.
Quand toutes vos formules seront faites et quelques lignes propagées vous pourrez même copier des lignes du milieu et faire Insertion cellules copiées.
Ensuite copier, collage spécial par valeur.
Cordialement

 

[Compte Supprimé 979]

Re : Données a remettre en place avec une nouvelle presentation

Bonjour Buzzzer,

Comme le dis Dranreb que je salue, avec la fonction DECALER() et quelques autres 😉😛😱

Voici ton fichier modifié avec une feuille BdD et "quelques" formules

ATTENTION !
La feuille de base doit contenir les informations qui commencent en B2 comme dans ton exemple

A+

 

[buzzzer]

Re : Données a remettre en place avec une nouvelle presentation

Merci Danreb,j'ai essayé mais ca marche pas j'ai du sauté une etape.
peux tu mettre ta formule dans le fichier pour que je vois la reaction.

merci

 

[Compte Supprimé 979]

Re : Données a remettre en place avec une nouvelle presentation

Re,

Heeee buzzzer et mon fichier ne te va pas !?
C'est bien la peine que ducro se décarcasse 😀

A+

 

[Victor21]

Re : Données a remettre en place avec une nouvelle presentation

Bonjour buzzer, et bienvenue.
Bonjour Dranreb ;

Une première approche :


Edit : Bonjour, Bruno 🙂

 

[david84]

Re : Données a remettre en place avec une nouvelle presentation

Bonjour tout le monde,
une possibilité via VBA à tester (code placé dans le module de la feuille 2) :

Sub Présentation()
Dim DerCol, Pl, TCol(), i&, j As Byte, Derlig&
Set Pl = Sheets("Feuil1").UsedRange
For i = 1 To Pl.Columns.Count
If Pl(1, i) <> "" Then
ReDim Preserve TCol(0 To j)
TCol(j) = i: j = j + 1
End If
Next i
With Sheets("Feuil2")
.[A2].Resize(.[A2].CurrentRegion.Rows.Count - 1, _
.[A2].CurrentRegion.Columns.Count).ClearContents

For i = LBound(TCol) To UBound(TCol)
Derlig = .Range("A" & .Rows.Count).End(xlUp).Row
.Cells(Derlig + 1, 1) = Pl(4, TCol(i))
.Cells(Derlig + 1, 2) = Pl(1, TCol(i))
.Cells(Derlig + 1, 3) = Pl(2, TCol(i))
.Cells(Derlig + 1, 4) = Left(Pl(14, TCol(i)), 5)
.Cells(Derlig + 1, 5) = Pl(13, TCol(i))
.Cells(Derlig + 1, 6) = Pl(6, TCol(i))
.Cells(Derlig + 1, 7) = Pl(16, TCol(i))
.Cells(Derlig + 1, 8) = Pl(18, TCol(i))
.Cells(Derlig + 1, 9) = Pl(20, TCol(i))
.Cells(Derlig + 1, 10) = Pl(8, TCol(i) + 1)
.Cells(Derlig + 1, 11) = Pl(10, TCol(i) + 1)
.Cells(Derlig + 1, 12) = Pl(12, TCol(i) + 1)
.Cells(Derlig + 1, 13) = Pl(13, TCol(i) + 1)
.Cells(Derlig + 1, 14) = Pl(14, TCol(i) + 1)
Next i
End With
End Sub
A+

 

[ROGER2327]

Re : Données a remettre en place avec une nouvelle presentation

Bonjour à tous

Une proposition en VBA.
Le code est dans le module de la feuille Feuil2. Il est exécuté chaque fois que cette feuille est activée.

Private Sub Worksheet_Activate()
Dim Plg As Range, dc(), sDat(), i&, j&, x$
    Set Plg = Feuil1.Range("B9:P28") 'plage de données à définir.
    dc = Array(14, Array(0, 3, 2), Array(0, 0, 0), Array(0, 1, 0), Array(0, 13, 1), Array(0, 12, 0), Array(0, 5, 2), Array(0, 15, 2), Array(0, 17, 2), Array(0, 19, 2), Array(1, 7, 2), Array(1, 9, 2), Array(1, 11, 3), Array(1, 12, 3), Array(1, 13, 3))
    ReDim sDat(1 To Plg.Columns.Count \ 3 + 1, 1 To dc(0))
    On Error Resume Next
    For i = 1 To UBound(sDat, 1)
        With Plg.Cells(1, 3 * i - 2)
            For j = 1 To dc(0)
                x = Trim(.Offset(dc(j)(1), dc(j)(0)).Value)
                Select Case dc(j)(2)
                Case 0: sDat(i, j) = x
                Case 1: sDat(i, j) = Split(x)(0)
                Case 2: sDat(i, j) = Trim(Split(x, ":")(1))
                Case 3: sDat(i, j) = Val(Split(x)(0))
                End Select
            Next
        End With
    Next
    On Error GoTo 0
    Cells.ClearContents
    Cells(1, 1).Resize(1, dc(0)).Value = Array("Code étab.", "Nom étab.", "Ville", "Code postal", "Adresse", "Directeur", "Tél.", "Fax", "Mail", "Nbrs classes", "Nbrs Eleves", "Nb. mater.", "Nb. élémentaire", "Nb. specialisé")
    Cells(2, 1).Resize(UBound(sDat, 1), dc(0)).Value = sDat
End Sub

Ajout : cette version n'est pas correcte. Voir #12.


ROGER2327
#5639

Lundi 23 Pédale 139 (Saint Masquerade, uniforme - fête Suprême Quarte)
27 Ventôse An CCXX, 5,3544h - sylvie
2012-W11-6T12:51:02Z

 

[buzzzer]

Re : Données a remettre en place avec une nouvelle presentation

Merci BrunoM45 et Dranreb c'est au poil ,c'est super!!!
Mon WE sera plus agreable................lol

 

[buzzzer]

Re : Données a remettre en place avec une nouvelle presentation

Ha oui merci aux autres contributions que j'avais pas vus!!!!😉

 

[david84]

Re : Données a remettre en place avec une nouvelle presentation

Re
En utilisant un array comme proposé par Roger, un essai d'adaptation de ma proposition initiale à tester :

Sub Présentation()
Dim DerCol, Pl, TCol(), Tablo(), i&, j As Byte, Derlig&, Pos
Pos = Array("", Array(3, 0), Array(0, 0), Array(1, 0), Array(13, 0), Array(12, 0), Array(5, 0), Array(15, 0), _
Array(17, 0), Array(19, 0), Array(7, 1), Array(9, 1), Array(11, 1), Array(12, 1), Array(13, 1))
Set Pl = Sheets("Feuil1").UsedRange

For i = 1 To Pl.Columns.Count
    If Pl(1, i) <> "" Then
        ReDim Preserve TCol(0 To j)
        TCol(j) = i: j = j + 1
    End If
Next i

For i = LBound(TCol) To UBound(TCol)
    For j = 1 To UBound(Pos)
        ReDim Preserve Tablo(LBound(TCol) To UBound(TCol), 1 To UBound(Pos))
        If j <> 3 Then
            Tablo(i, j) = Pl(1, TCol(i)).Offset(Pos(j)(0), Pos(j)(1))
        Else
            Tablo(i, j) = Left(Pl(1, TCol(i)).Offset(Pos(j)(0), Pos(j)(1)), 5)
        End If
        Next j
    Next i

With Sheets("Feuil2")
    .[A2].Resize(.[A2].CurrentRegion.Rows.Count - 1, _
    .[A2].CurrentRegion.Columns.Count).ClearContents
    .[A2].Resize(UBound(TCol) + 1, UBound(Pos)) = Tablo
End With
    
End Sub

A+

 

[ROGER2327]

Re : Données a remettre en place avec une nouvelle presentation

Suite...

En relisant le message #8, je vois que le paramétrage du code n'est pas logique. En voici une version légèrement moins bourrin :

Private Sub Worksheet_Activate()
Dim Plg As Range, Dc(), sDat(), i&, j&, x$
    With Feuil1.Range("B9:B28") 'première colonne de données
        Set Plg = .Resize(, .Cells(1, Columns.Count - .Column + 1).End(xlToLeft).Column + 3 - .Column)
    End With
    Dc = Array(0, Array("Code étab.", 0, 3, 2), Array("Nom étab.", 0, 0, 0), Array("Ville", 0, 1, 0), Array("Code postal", 0, 13, 1), Array("Adresse", 0, 12, 0), Array("Directeur", 0, 5, 2), Array("Tél.", 0, 15, 2), Array("Fax", 0, 17, 2), Array("Mail", 0, 19, 2), Array("Nb. classes", 1, 7, 2), Array("Nb. Eleves", 1, 9, 2), Array("Nb. mater.", 1, 11, 3), Array("Nb. élémentaire", 1, 12, 3), Array("Nb. specialisé", 1, 13, 3))
    Dc(0) = UBound(Dc)
    sDat = Extraction(Plg, Dc)
    Cells.ClearContents
    Cells(1, 1).Resize(UBound(sDat, 1), Dc(0)).Value = sDat
End Sub

Function Extraction(Plg As Range, Dc())
Dim sDat(), i&, j&, x$
    ReDim sDat(0 To Plg.Columns.Count \ 3 + 1, 1 To Dc(0))
    For j = 1 To Dc(0): sDat(0, j) = Dc(j)(0): Next
    On Error Resume Next
    For i = 1 To UBound(sDat, 1)
        With Plg.Cells(1, 3 * i - 2)
            For j = 1 To Dc(0)
                x = Trim(.Offset(Dc(j)(2), Dc(j)(1)).Value)
                Select Case Dc(j)(3)
                Case 0: sDat(i, j) = x
                Case 1: sDat(i, j) = Split(x)(0)
                Case 2: sDat(i, j) = Trim(Split(x, ":")(1))
                Case 3: sDat(i, j) = Val(Split(x)(0))
                End Select
            Next
        End With
    Next
    On Error GoTo 0
    Extraction = sDat
End Function

ROGER2327
#5640

Lundi 23 Pédale 139 (Saint Masquerade, uniforme - fête Suprême Quarte)
27 Ventôse An CCXX, 7,1293h - sylvie
2012-W11-6T17:06:37Z