Déplacer des informations de ligne en colonne selon un champ

Le 27/04/2015 à 17:00

Bonjour à tous,

Je dispose d'un tableau listant les propriétaires de parcelles cadastrales avec une ligne pour chaque occurrence "Propriétaire/Parcelle".

Les parcelles pouvant disposer de plusieurs propriétaires, je souhaiterais pour intégration à un SIG n'avoir qu'une seule ligne par parcelle, mais je souhaiterais conserver l'intégralité des informations des différents propriétaires en créant de manière automatique (étant donné qu'il y en 149614) pour chaque ligne "parcelle" autant de colonnes "Propriétaire/Adresse/Type de propriété" qu'il n'y a de propriétaires supplémentaires.

Une petite illustration de mon vœu :

Voici comment se présente la base de données :

Parcelle | Nom | Adresse | Type

0B0012 | M MACHIN Apollon | 2 IMPASSE DU SENS UNIQUE | Usufruitier

0B0012 | M MACHIN Zeus | 2 IMPASSE DU SENS UNIQUE | Nu-propriétaire

0B0012 | M MACHIN Bacchus | 2 IMPASSE DU SENS UNIQUE | Nu-propriétaire

0B0013 | M TRUQUE Gandalf | 24 CHEMIN DU PASSAGE | Propriétaire

Et voici ce que je souhaiterais obtenir :

Parcelle | Nom 1 | Adresse 1 | Type 1 | Nom | Adresse 2 | Type 2 | Nom 3 | Adresse 3 | Type 3 | Nom 4 | Adresse 4 | Type 4 | ...

0B0012 | M MACHIN Apollon | 2 IMPASSE DU SENS UNIQUE | Usufruitier | M MACHIN Zeus | 2 IMPASSE DU SENS UNIQUE | Nu-propriétaire | M MACHIN Bacchus | 2 IMPASSE DU SENS UNIQUE | Nu-propriétaire |||| ...

0B0013 | M TRUQUE Gandalf | 24 CHEMIN DU PASSAGE | Propriétaire |||||||||| ...

Si vous avez la solution, je suis tout ouïe !

Merci d'avance de vos suggestions !

Le 27/04/2015 à 17:05

Bonjour,

Si tu as besoin d'une réponse de principe ... la fonction DECALER() peut remplir cette tâche ...

Si tu as besoin d'une réponse adaptée à la configuration de ton fichier ... il faudra ... joindre ton fichier ...

Le 27/04/2015 à 18:05

Bonjour,

une proposition de macro, suppose ton fichier déjà chargé en excel dans une feuille nommée sheet1, résultat dans un fichier au format demandé pour ton SIG.

Sub reformat()
    Dim a As Variant, t as variant
    Set ws1 = Sheets("sheet1")    ' feuille contenant les données à reformatter
    dlws1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    ws1.Range("A1:A" & dlws1).TextToColumns Destination:=ws1.Range("A1"), DataType:=xlDelimited, Other:=True, OtherChar:="|"
    a = ws1.Range("A1:d" & dlws1)
    oldpc = ""
    i = 2
    li = 1
    ReDim t(100, 164000)
    For i = LBound(a, 1) To UBound(a, 1)
        If a(i, 1) <> oldpc Then
            li = li + 1
            col = 2
            oldpc = a(i, 1)
            ncol = UBound(t, 2)
            t(1, li) = oldpc
        End If
        col = col + 3
        If col > maxcol Then maxcol = col
        t(col, li) = a(i, 2)
        t(col + 1, li) = a(i, 3)
        t(col + 2, li) = a(i, 4)
    Next i

    maxcol = maxcol + 2
    t(1, 0) = "parcelle"
    ctr = 0
    For i = 1 To col Step 3
        ctr = ctr + 1
        t(i, 0) = "Nom " & ctr
        t(i + 1, 0) = "Adresse " & ctr
        t(i + 2, 0) = "type " & ctr
    Next i
    fn = Application.GetSaveAsFilename
    If fn = "" Then
        MsgBox "fichier non sauvé"
    Else
        Open fn For Output As 1
        For i = 0 To li
            b = ""
            sep = b
            For j = 1 To maxcol
                b = b & sep & t(j, i)
                sep = "|"
            Next j
            Print #1, b
        Next i
        Close 1
        MsgBox "fichier " & fn & " crée avec " & li & " lignes"
    End If
End Sub
Le 27/04/2015 à 19:39

Bonsoir,

Bonsoir H2SO4

Il eût été préférable de joindre un fichier à ta demande...

Regarde le fichier joint,

J'ai supposé que tu n'avais que 4 colonnes, et un nombre conséquent de lignes (bien que le nombre de 149614 m'interpelle un peu....)

Donc, je balaie le tableau, et à partir de la cellule G1, je recopie comme tu le souhaites...

Le code :

Option Base 1
Sub concat()
Dim TblBrut
Dim TblFin()
Dim Parcs As Object
Dim I As Long, NbCol As Long, J As Long, K As Long, L As Long, M As Long
Dim Ke
Set Parcs = CreateObject("Scripting.Dictionary")
TblBrut = Range("A2:D" & Cells(Rows.Count, 1).End(xlUp).Row)
For I = LBound(TblBrut) To UBound(TblBrut)
    Parcs(TblBrut(I, 1)) = Parcs(TblBrut(I, 1)) + 1
Next I
NbCol = (Application.Max(Parcs.Items) * 3) + 1
ReDim TblFin(Parcs.Count, NbCol)
J = 1: K = 0: L = 1
For Each Ke In Parcs.Keys
    M = 2
    TblFin(J, 1) = Ke
    For K = 2 To NbCol
        If K <= (Parcs(Ke) * 3) + 1 Then
            TblFin(J, K) = TblBrut(L, M): M = M + 1
            If (K - 1) Mod 3 = 0 Then L = L + 1: M = 2
        Else
            Exit For
        End If
    Next K
    J = J + 1
Next Ke
Range("G2").Resize(Parcs.Count, NbCol) = TblFin
Range("G1") = Range("A1")
Range("B1:D1").Copy Range("H1").Resize(1, NbCol - 1)
End Sub

Le fichier :

15parcelles-v1.xlsm (31.70 Ko)
Le 27/04/2015 à 21:59

Bonsoir à tous

Avec le fichier fourni par cousinhub.

A tester, résultat en Feuil2:

Option Explicit

Sub Regroupement()
Dim a, i As Long, j As Long, n As Long, col As Byte, w
    a = Sheets("Feuil1").Cells(1).CurrentRegion.Value
    col = UBound(a, 2): n = 1: a(1, 1) = "Parcelles"
    a(1, 2) = "Nom1": a(1, 3) = "Adresse1": a(1, 4) = "Type1"
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1: .Item(a(i, 1)) = VBA.Array(n, col)
                For j = 1 To col
                    a(n, j) = a(i, j)
                Next
            Else
                w = .Item(a(i, 1)): w(1) = w(1) + 3
                If UBound(a, 2) < w(1) Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
                    a(1, w(1) - 2) = a(1, 2)
                    a(1, w(1) - 1) = a(1, 3)
                    a(1, w(1)) = a(1, 4)
                End If
                For j = 1 To 3
                    a(w(0), w(1) - 3 + j) = a(i, j + 1)
                Next
                .Item(a(i, 1)) = w
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
        .CurrentRegion.Clear
        .Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 43
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
        End With
        If UBound(a, 2) > 4 Then
            With .Offset(, 1).Resize(1, 3)
                .AutoFill .Resize(, UBound(a, 2) - 1)
            End With
        End If
        .Parent.Select
    End With
    Application.ScreenUpdating = True
End Sub

klin89

14parcelles.zip (32.03 Ko)
Le 27/04/2015 à 22:27

Bonsoir,

@ Klin

Je me suis amusé à comparer nos codes (en temps de résolution)

J'ai donc créé un petit code, qui m'a permis de générer 148040 lignes, avec 18504 parcelles différentes....

Ce qui m'a rassuré, c'est qu'on trouve le même tableau final...

Et en temps de résolution, avec mon code : 2,41 secondes, avec le tien : 5,92 secondes.

Sachant que dans ton code, tu exportes vers un autre onglet, que tu numérotes les noms1, noms2, etc....

C'est quand même pas mal...

Je pense que quelque soit le code qu'il va choisir, il aura ce qu'il faut, en moins de temps qu'il ne m'a fallu pour écrire ce post....

Bonne soirée

Le 09/02/2016 à 11:13

Bonjour à tous,

Je vous remercie vivement tout d'abord pour ces propositions de macros avec lesquelles j'avais pu parvenir l'an dernier à mes fins en retravaillant mes données selon la trame de tableau simplifié que je vous avais fournie.

Dans les faits, mon tableau fait 8 colonnes, mais surtout, la colonne "Parcelle" s'appelle en fait "Num_Parcelle" et n'est pas en A mais en D.

Pour le nombre de lignes, on est sur du 263 461 (couples propriétaire/parcelle) pour 150 000 parcelles, ordre d'idée qui peut légèrement changer d'année en année.

Pour ce qui est du nombre maximum de propriétaires par parcelle, on est à 6 avec la base actuelle, sachant que ça pourrait tendre vers une infinité, dans les limites du raisonnable bien sûr !

Dans ce cadre, je pense que les macros proposées ne fonctionneront pas, du fait notamment que "Num_Parcelle" ne soit pas en A.

C'est pourquoi je reviens vers vous afin de voir s'il était possible d'adapter ces macros à mes données réelles.

En vous remerciant d'avance de vos réponses.

Bien cordialement,

Le 09/02/2016 à 18:53

Le 09/02/2016 à 19:33

Bonjour SMPSS, h2so4, le forum

9 mois pour accoucher d'une réponse, à priori rien d'anormal

Trêve de plaisanterie !

Comme tu es peu enclin à nous fournir un fichier, précise nous au moins l'ordre de tes en-têtes dans la feuille source et la restitution souhaité dans la feuille cible.

Tu nous parles désormais de 8 colonnes et non plus 4 comme initialement.

klin89

Le 10/02/2016 à 15:57

Bonjour,

Je vous prie tout d'abord de m'excuser d'avoir mis de côté cette discussion, sachant que j'allais y revenir mais pas dans l'immédiat.

J'aurais effectivement dû vous proposer dès le début un bout de fichier fictif correspondant à mon fichier de départ et j'en suis désolé.

Voici donc un exemple fictif, avec en feuille 1, les données brutes, et en feuille 2, le résultat souhaité :

12exemple.xlsx (10.68 Ko)

Il y a donc une seule valeur de B, C ou D (INSEE, Parcelle et Compte) pour un même A (Numéro de parcelle)

Il y a en revanche plusieurs couples "E/F/G/H" (Propriétaire, Type, Naissance et Adresse) pour un même A (Numéro de Parcelle)

En vous remerciant d'avance de vos réponses.

Bien cordialement,

Le 10/02/2016 à 19:55

Re SMPSS,

Le code modifié pour la circonstance :

Option Explicit

Sub test()
Dim a, i As Long, j As Long, n As Long, col As Byte, w()
Dim dico As Object
    a = Sheets("Feuil1").Range("A1").CurrentRegion.Value
    col = UBound(a, 2): n = 1: a(1, 5) = "Nom_1"
    a(1, 6) = "Type_1": a(1, 7) = "Naissance_1": a(1, 8) = "Adresse_1"
    Set dico = CreateObject("Scripting.Dictionary")
    dico.comparemode = 1
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 1)) Then
            n = n + 1: dico(a(i, 1)) = VBA.Array(n, col)
            For j = 1 To col
                a(n, j) = a(i, j)
            Next
        Else
            w = dico(a(i, 1)): w(1) = w(1) + 4
            If UBound(a, 2) < w(1) Then
                ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
            End If
            For j = 1 To 4
                a(w(0), w(1) - 4 + j) = a(i, j + 4)
            Next
            dico(a(i, 1)) = w
        End If
    Next
    'Restitution et mise en forme en feuil2
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
        .Parent.Cells.Clear
        .Value = a
        If UBound(a, 2) > col Then
            With .Offset(, 4).Resize(1, 4)
                .AutoFill .Resize(, UBound(a, 2) - col + 4)
            End With
        End If
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        With .Rows(1)
            .Font.Size = 11
            .BorderAround Weight:=xlThin
            With .Offset(, 1).Resize(, 3)
                .Interior.ColorIndex = 40
            End With
            With .Offset(, 4).Resize(, .Columns.Count - 4)
                .Interior.ColorIndex = 38
            End With
        End With
        With .Columns(1).Offset(1).Resize(.Rows.Count - 1)
            .Interior.ColorIndex = 19
        End With
        .Columns.AutoFit
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 11/02/2016 à 17:16

Bonjour Klin89,

Je te remercie pour cet ajustement selon le format de mon tableau de base. La macro fonctionne parfaitement de manière générale, mais certains détails pêchent encore, concernant essentiellement à priori le format de certaines colonnes de résultats en Feuil2.

Le premier problème concerne les parcelles ayant un "Code_Parcelle" en colonne A de la forme "000000E0001" à "000000E0309" et un "Parcelle" en colonne C de la forme "0E0001" à "0E0309"

Si ce type de contenu arrive dans une cellule au format "Standard", Excel croit que c'est une écriture scientifique et la retransforme automatiquement en un contenu indésirable avec impossibilité de revenir en arrière.

Ex : 180300E0031 devient 1.803+31 ; 0E0031 devient 0.00E+00

J'avais solutionné le problème en amont grâce à cette discussion (https://forum.excel-pratique.com/excel/supprimer-la-reconnaissance-auto-d-une-ecriture-scientifique-t51817.html) en mettant au préalable les cellules en format texte et en les faisant précéder par une apostrophe pour celles qui commencent par "0" (pour la colonne "Parcelle").

Le second problème concerne, de la même manière, le contenu de la colonne D (Compte), qui est altéré pour les contenus commençant par +.

Ex : +00001 devient 1

En résumé et avec mon faible bagage technique en termes de programmation informatique, il semble qu'il faille "préparer" le format des colonnes A, C et D de la Feuil2 en Texte, avec une apostrophe devant concernant C.

En te remerciant d'avance de cet ajustement qui permettra à cette macro de fonctionner de manière optimale, puisque je pourrai avoir accès aux noms des propriétaires de parcelles en 0E0001 à 0E0309 sous SIG après jointure, chose que je ne pouvais pas jusqu'à présent.

Bien cordialement,

Le 11/02/2016 à 22:10

Re SMPSS,

Pour les colonnes A et C, j'ai modifié ainsi :

 For i = 2 To UBound(a, 1)
        a(i, 1) = CStr(a(i, 1)): a(i, 3) = CStr(a(i, 3))
        If Not dico.exists(a(i, 1)) Then
With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
        With .Parent
            .Cells.Clear
            .Columns("a").NumberFormat = "@"
            .Columns("c").NumberFormat = "@"
        End With
        .Value = a

Dis moi si c'est ok.

Option Explicit

Sub test()
Dim a, i As Long, j As Long, n As Long, col As Byte, w()
Dim dico As Object
    a = Sheets("Feuil1").Range("A1").CurrentRegion.Value
    col = UBound(a, 2): n = 1: a(1, 5) = "Nom_1"
    a(1, 6) = "Type_1": a(1, 7) = "Naissance_1": a(1, 8) = "Adresse_1"
    Set dico = CreateObject("Scripting.Dictionary")
    dico.comparemode = 1
    For i = 2 To UBound(a, 1)
        a(i, 1) = CStr(a(i, 1)): a(i, 3) = CStr(a(i, 3))
        If Not dico.exists(a(i, 1)) Then
            n = n + 1: dico(a(i, 1)) = VBA.Array(n, col)
            For j = 1 To col
                a(n, j) = a(i, j)
            Next
        Else
            w = dico(a(i, 1)): w(1) = w(1) + 4
            If UBound(a, 2) < w(1) Then
                ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
            End If
            For j = 1 To 4
                a(w(0), w(1) - 4 + j) = a(i, j + 4)
            Next
            dico(a(i, 1)) = w
        End If
    Next
    'Restitution et mise en forme en feuil2
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
        With .Parent
            .Cells.Clear
            .Columns("a").NumberFormat = "@"
            .Columns("c").NumberFormat = "@"
        End With
        .Value = a
        If UBound(a, 2) > col Then
            With .Offset(, 4).Resize(1, 4)
                .AutoFill .Resize(, UBound(a, 2) - col + 4)
            End With
        End If
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        With .Rows(1)
            .Font.Size = 11
            .BorderAround Weight:=xlThin
            With .Offset(, 1).Resize(, 3)
                .Interior.ColorIndex = 40
            End With
            With .Offset(, 4).Resize(, .Columns.Count - 4)
                .Interior.ColorIndex = 38
            End With
        End With
        With .Columns(1).Offset(1).Resize(.Rows.Count - 1)
            .Interior.ColorIndex = 19
        End With
        .Columns.AutoFit
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

Je n'ai pas regardé pour la colonne D

klin89

Le 12/02/2016 à 09:02

Bonjour Klin89,

J'ai testé ta nouvelle proposition de macro et elle solutionne parfaitement le problème de la mise en forme automatique en écriture scientifique pour les colonnes A et C.

Pour la colonne D, je me suis inspiré de ton code pour résoudre également le problème :

    With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
        With .Parent
            .Cells.Clear
            .Columns("a").NumberFormat = "@"
            .Columns("c").NumberFormat = "@"
            [u].Columns("d").NumberFormat = "@"[/u]
        End With
        .Value = a

Et tout fonctionne parfaitement ! Un grand merci à toi ! A bientôt !

Le 28/02/2017 à 15:57

Bonjour à tous,

Au fur et à mesure de mes pérégrinations, je m'aperçois que je dois faire la même manip que précédemment avec toujours 4 champs "uniques" mais désormais non plus 4 champs "multiples" mais 5.

Il y a donc maintenant :

  • une seule valeur de B, C ou D (Com_Parc, Num_Parc et Adr_Parc) pour un même A (Num_Parc)
  • Il y a en revanche plusieurs couples "E/F/G/H/I" (NomComp_Prop, NomUsg_Prop, Adr_Prop, Nsc_Prop et Typ_Prop) pour un même A (Numéro de Parcelle)

Voici la macro initiale :

Option Explicit

Sub test()
Dim a, i As Long, j As Long, n As Long, col As Byte, w()
Dim dico As Object
    a = Sheets("Feuil1").Range("A1").CurrentRegion.Value
    col = UBound(a, 2): n = 1: a(1, 5) = "Nom_1"
    a(1, 6) = "Type_1": a(1, 7) = "Naissance_1": a(1, 8) = "Adresse_1"
    Set dico = CreateObject("Scripting.Dictionary")
    dico.comparemode = 1
    For i = 2 To UBound(a, 1)
        a(i, 1) = CStr(a(i, 1)): a(i, 3) = CStr(a(i, 3))
        If Not dico.exists(a(i, 1)) Then
            n = n + 1: dico(a(i, 1)) = VBA.Array(n, col)
            For j = 1 To col
                a(n, j) = a(i, j)
            Next
        Else
            w = dico(a(i, 1)): w(1) = w(1) + 4
            If UBound(a, 2) < w(1) Then
                ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
            End If
            For j = 1 To 4
                a(w(0), w(1) - 4 + j) = a(i, j + 4)
            Next
            dico(a(i, 1)) = w
        End If
    Next
    'Restitution et mise en forme en feuil2
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
        With .Parent
            .Cells.Clear
            .Columns("a").NumberFormat = "@"
            .Columns("c").NumberFormat = "@"
            .Columns("d").NumberFormat = "@"
        End With
        .Value = a
        If UBound(a, 2) > col Then
            With .Offset(, 4).Resize(1, 4)
                .AutoFill .Resize(, UBound(a, 2) - col + 4)
            End With
        End If
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        With .Rows(1)
            .Font.Size = 11
            .BorderAround Weight:=xlThin
            With .Offset(, 1).Resize(, 3)
                .Interior.ColorIndex = 40
            End With
            With .Offset(, 4).Resize(, .Columns.Count - 4)
                .Interior.ColorIndex = 38
            End With
        End With
        With .Columns(1).Offset(1).Resize(.Rows.Count - 1)
            .Interior.ColorIndex = 19
        End With
        .Columns.AutoFit
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

Intuitivement, j'ai compris qu'il fallait citer les 5 champs "multiples" de a(1,5) à a(1,9) et que des 4 devaient être changés probablement en 5, mais ne comprenant pas la syntaxe de la macro, je ne sais pas lesquels je dois changer.

A moins qu'il ne faille modifier d'autres éléments de la macro pour l'adapter au problème.

Auriez-vous la solution pour adapter cette macro à mon nouveau cas de figure ?

En vous remerciant d'avance de vos réponses.

Bien cordialement,

Le 28/02/2017 à 20:55

Re SMPSS,

le code réajusté suite au rajout d'une colonne :

Option Explicit

Sub test()
Dim a, i As Long, j As Long, n As Long, col As Byte, w()
Dim dico As Object
    a = Sheets("Feuil1").Range("A1").CurrentRegion.Value
    col = UBound(a, 2): n = 1: a(1, 5) = "Nom_1"
    a(1, 6) = "Type_1": a(1, 7) = "Naissance_1"
    a(1, 8) = "Adresse_1": a(1, 9) = "Rajout_1":
    Set dico = CreateObject("Scripting.Dictionary")
    dico.comparemode = 1
    For i = 2 To UBound(a, 1)
        a(i, 1) = CStr(a(i, 1)): a(i, 3) = CStr(a(i, 3))
        If Not dico.exists(a(i, 1)) Then
            n = n + 1: dico(a(i, 1)) = VBA.Array(n, col)
            For j = 1 To col
                a(n, j) = a(i, j)
            Next
        Else
            w = dico(a(i, 1)): w(1) = w(1) + 5
            If UBound(a, 2) < w(1) Then
                ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
            End If
            For j = 1 To 5
                a(w(0), w(1) - 5 + j) = a(i, j + 4)
            Next
            dico(a(i, 1)) = w
        End If
    Next
    'Restitution et mise en forme en feuil2
   Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
        With .Parent
            .Cells.Clear
            .Columns("a").NumberFormat = "@"
            .Columns("c").NumberFormat = "@"
            .Columns("d").NumberFormat = "@"
        End With
        .Value = a
        If UBound(a, 2) > col Then
            With .Offset(, 4).Resize(1, 5)
                .AutoFill .Resize(, UBound(a, 2) - col + 5)
            End With
        End If
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        With .Rows(1)
            .Font.Size = 11
            .BorderAround Weight:=xlThin
            With .Offset(, 1).Resize(, 3)
                .Interior.ColorIndex = 40
            End With
            With .Offset(, 4).Resize(, .Columns.Count - 4)
                .Interior.ColorIndex = 38
            End With
        End With
        With .Columns(1).Offset(1).Resize(.Rows.Count - 1)
            .Interior.ColorIndex = 19
        End With
        .Columns.AutoFit
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 01/03/2017 à 10:47

Bonjour Klin89,

Je te remercie pour cet ajustement qui a l'air de fonctionner parfaitement !

A bientôt !

Rechercher des sujets similaires à "deplacer informations ligne colonne champ"