Données a remettre en place avec une nouvelle presentation

buzzzer · 17 Mars 2012

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

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:

Code:

=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 · 17 Mars 2012

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

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

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

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

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

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.

VB:

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

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

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

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

david84 · 17 Mars 2012

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 :

Code:

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

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 :

VB:

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

Données a remettre en place avec une nouvelle presentation

buzzzer

Guest

Pièces jointes

Dranreb

XLDnaute Barbatruc

Compte Supprimé 979

Guest

Pièces jointes

buzzzer

Guest

Compte Supprimé 979

Guest

Victor21

XLDnaute Barbatruc

Pièces jointes

david84

XLDnaute Barbatruc

Pièces jointes

ROGER2327

XLDnaute Barbatruc

Pièces jointes

buzzzer

Guest

buzzzer

Guest

david84

XLDnaute Barbatruc

ROGER2327

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Données a remettre en place avec une nouvelle presentation

buzzzer

Guest

Pièces jointes

Dranreb

XLDnaute Barbatruc

Compte Supprimé 979

Guest

Pièces jointes

buzzzer

Guest

Compte Supprimé 979

Guest

Victor21

XLDnaute Barbatruc

Pièces jointes

david84

XLDnaute Barbatruc

Pièces jointes

ROGER2327

XLDnaute Barbatruc

Pièces jointes

buzzzer

Guest

buzzzer

Guest

david84

XLDnaute Barbatruc

ROGER2327

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency