Autres création d'un TCD avec mise en forme de données en VBA

[labuse]

Bonjour, je débute en VBA et je suis en difficulté:
j'ai une feuille excel composée de plusieurs tableaux (feuil2 du fichier) et j'aimerai pouvoir copier la cellule en gras sur tout le tableau (pour le premier tableau Cellule A5 à copier sur A7 jusqu'a A29
Le problème c'est que les tableaux sont de longueurs différentes à chaque fois
j'ai essayé de coder qcch mais je n'arrive pas au bout
l'objectif final est de sortie un TCD qui me dit le nb de CP, RTT maladie par personne
PS : j'ai des tableaux de ce genre jusqu'a la ligne 1200 environ

 

[labuse]

explication du code que j'ai fait :
aller a la feuille 2
Défusionner les cellules
selectionner les colonne I:J remplacer la , dans ces colonnes par un .
c'est après que ca ne fonctionne plus
j'ai crée une boucle qui détecte le mot nature dans la colonne A pour copier le nom (toujours 2 lignes au dessus de la cellule nature) j'ai mis de 1 a 100 pour tester plus rapidement.
et la copier tant que la cellule d'en dessous est non vide
Merci d'avance pour votre aide

 

[Phil69970]

Bonjour @labuse et bienvenu sur XLD

Met un exemple de ce que tu veux faire c'est à dire le résultat final (pour 2 tableaux) car j'ai pas tout compris de tes explications...

Donc montre nous AVANT/APRES pour voir ce qu'il faut faire et si c'est sur la même feuille ou sur une nouvelle feuille

Et modifie ton titre car il contraire à la charte mais un titre plus explicite.

@Phil69970

 

[labuse]

Bonjour @Phil69970 merci pour ta réponse et ton accueil.
j'ai crée le TCD a obtenir en feuil 4
Il faudrait copier le nom des personnes dans le tableau qui suit leur nom pour chaque ligne
Il faut supprimer les espaces en trop entre les tableaux et les entêtes en trop filtrer la colonne avec les entête (modifier l'entête nature par nom) et créé le TCD

 

[job75]

Bonjour,

Je me contente de la macro demandée au post #1 :

Sub ModifierColonne()
Dim c As Range
Application.ScreenUpdating = False
With Feuil2 'CodeName
   .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If c.Column = 1 Then c.CurrentRegion.Columns(1) = c(-1)
    Next
End With
End Sub

Edit : oublié le point devant [A:A]...

A+

 

[labuse]

Bonjour,

Je me contente de la macro demandée au post #1 :

Sub ModifierColonne()
Dim c As Range
Application.ScreenUpdating = False
With Feuil2 'CodeName
    [A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In [A:A].SpecialCells(xlCellTypeConstants, 16)
        If c.Column = 1 Then c.CurrentRegion.Columns(1) = c(-1)
    Next
End With
End Sub

A+

Merci beaucoup ça m'avance énormément

 

[labuse]

j'ai réussi a supprimer les lignes vides en trop Tout ce qu'il manque c'est la création des entêtes, je pourrai créer le TCD manuellement après ça

 

[chris]

Bonjour à tous

Quelle est version Excel ?

 

[job75]

La macro qui supprime les lignes pour créer le tableau source :

Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

Pour le TCD il est aussi simple de le créer manuellement.

 

[Phil69970]

Bonjour à tous

@labuse je te propose ce fichier

@merci de ton retour

@Phil69970

 

[job75]

J'oubliais, il faut aussi supprimer les colonnes B K L (fusionnées) :

Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .[B:B,K:L].Delete
    .Columns.AutoFit 'ajustement largeurs
    .Rows.AutoFit 'ajustement hauteurs
End With
End Sub

 

[job75]

Autre oubli : Nb jours et Nb heures sont des textes, il faut les convertir en nombres :

Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .[B:B,K:L].Delete
    .Columns.AutoFit 'ajustement largeurs
    .Rows.AutoFit 'ajustement hauteurs
    .[H:I].Replace ",", ".", xlPart 'conversion des textes en nombres
End With
End Sub

 

[labuse]

Autre oubli : Nb jours et Nb heures sont des textes, il faut les convertir en nombres :

Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .[B:B,K:L].Delete
    .Columns.AutoFit 'ajustement largeurs
    .Rows.AutoFit 'ajustement hauteurs
    .[H:I].Replace ",", ".", xlPart 'conversion des textes en nombres
End With
End Sub

re, j'avais réussi à enlever les colonne et faire le remplacement en regardant d'autres forums mais merci bcp
le sujet est clos pour ma part
merci pour votre réactivité et vos solutions
@Phil69970 70 et @job75