IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Modification de macro pour insertion au bon endroit


Sujet :

Macros et VBA Excel

Vue hybride

Message précédent Message précédent   Message suivant Message suivant
  1. #1
    Membre averti
    Homme Profil pro
    Chef de projet MOA
    Inscrit en
    Juillet 2018
    Messages
    12
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 33
    Localisation : France, Maine et Loire (Pays de la Loire)

    Informations professionnelles :
    Activité : Chef de projet MOA
    Secteur : Bâtiment

    Informations forums :
    Inscription : Juillet 2018
    Messages : 12
    Par défaut Modification de macro pour insertion au bon endroit
    Bonjour,

    Je dispose d'une macro me permettant une récupération de la table des matière Word pour la copier dans une feuille excel.
    J'aimerais la modifier pour que ces titres s'insèrent à la ligne souhaitée (a partir d'A6 sur une autre feuille)
    Voici le code :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    Sub Recuperation()
    Dim WordAppli As Word.Application
    'Dim ExcelAppli As Excel.Application
    Dim WordDoc As Word.Document
    Dim oChemin As String, oChapitre As String
    Dim oWksh As Worksheet
    Dim oLast As Integer, n As Integer, i As Integer, j As Integer
    Dim oRng_table As Range
    Dim oTable_matiere() As String, oDecomp() As String, oNewRech As String
     
    With ThisWorkbook
    'Changer le titre par le titre exact de la nouvelle page excel
        With .Worksheets("Util")
            oChemin = .Range("B1")
            oChapitre = .Range("B2")
        End With
        Set oWksh = Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
    End With
     
     
    On Error Resume Next
    Set WordAppli = GetObject(, "Word.Application")
    Set WordDoc = WordAppli.Documents(oChemin)
     
    If WordDoc Is Nothing Then
        Set WordAppli = CreateObject("Word.Application")
        WordAppli.Documents.Open Filename:=oChemin
        Set WordDoc = WordAppli.Documents(oChemin)
    End If
    'Problème ici
     
    WordAppli.Visible = True
     
    With WordDoc
        .TablesOfContents(1).Range.Copy
    End With
     
    With oWksh
        .PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
        Set oRng_table = .Columns(1).Find(oChapitre, LookIn:=xlValues, LookAt:=xlWhole)
        If Not oRng_table Is Nothing Then
            n = 1
            Do While Left(oRng_table.Offset(n - 1, 0), 1) = oChapitre
                ReDim Preserve oTable_matiere(1 To 2, 1 To n)
                If Right(oRng_table.Offset(n - 1, 0), 1) = "." Then
                    oTable_matiere(1, n) = oRng_table.Offset(n - 1, 0)
                Else
                    oTable_matiere(1, n) = oRng_table.Offset(n - 1, 0) & "."
                End If
                oTable_matiere(2, n) = oRng_table.Offset(n - 1, 1)
                n = n + 1
            Loop
        Else
            MsgBox "Le chapitre souhaité n'est pas présent dans le document."
            Exit Sub
        End If
    End With
     
    With ThisWorkbook.Worksheets("Feuil3")
    'Changer le titre par le titre exact de la nouvelle page excel
        For i = LBound(oTable_matiere, 2) To UBound(oTable_matiere, 2)
            Set oRng_table = .Columns(1).Find(oTable_matiere(1, i), LookIn:=xlValues, LookAt:=xlWhole)
            If oRng_table Is Nothing Then
                oDecomp() = Split(oTable_matiere(1, i), ".")
     
                n = 1
                Do While True
                    oNewRech = ""
                    For j = LBound(oDecomp) To UBound(oDecomp) - n
                        oNewRech = oNewRech & oDecomp(j) & "."
                    Next j
     
                    Set oRng_table = .Columns(1).Find(oNewRech, LookIn:=xlValues, LookAt:=xlWhole)
                    If oRng_table Is Nothing Then
                        If Compte_point(oNewRech) > 2 Then
                            n = n + 1
                        Else
                            Call Creation_chapitre(oTable_matiere(1, i), oTable_matiere(2, i))
                            Exit Do
                        End If
                    Else
                        Call Creation_intitule(oTable_matiere(1, i), oTable_matiere(2, i), oRng_table)
                        Exit Do
                    End If
                Loop
            End If
        Next i
        Application.DisplayAlerts = False
        oWksh.Delete
        Application.DisplayAlerts = True
        .Select
    End With
     
    End Sub
     
    Sub Creation_chapitre(oChap As String, oIntit As String)
    Dim oRng As Range
     
    With ThisWorkbook.Worksheets("Feuil3")
    'Changer le titre par le titre exact de la nouvelle page excel
        Set oRng = .Cells(.Rows.Count, 1).End(xlUp)
        oRng.Offset(1, 0).EntireRow.Insert
        oRng.Offset(1, 0).EntireRow.Insert
    'rien changé
     
        oRng.Offset(2, 0) = oChap
        oRng.Offset(2, 1) = oIntit
        'Les 2 derniere lignes modifient l'écart
     
        oRng.Offset(2, 0).EntireRow.Font.Color = RGB(0, 0, 0)
    End With
     
    End Sub
     
    Sub Creation_intitule(oChap As String, oIntit As String, oRng_table As Range)
     
    With oRng_table
        .Offset(1, 0).EntireRow.Insert
     
        .Offset(1, 0) = oChap
        .Offset(1, 1) = oIntit
     
        .Offset(1, 0).EntireRow.Font.Color = RGB(0, 0, 0)
    End With
     
    End Sub
     
    Function Compte_point(oStr As String) As Integer
    Dim i As Integer
    Dim oCount As Integer
     
    For i = 1 To Len(oStr)
        If Mid(oStr, i, 1) = "." Then
            oCount = oCount + 1
        End If
    Next i
     
    Compte_point = oCount
    End Function
    Pour palier à ce problème, j'ai créé une autre macro "couper - insérer" pour que les titres se mettent au bon endroit, avec une macro fusion de macro, tout se passe bien :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    Sub Copie1()
    Dim O As Worksheet
    'déclare la variable O (Onglet)
    Dim LD As Integer
    'déclare la variable LD (Ligne Début)
    Dim LF As Integer
    'déclare la variable LF (Ligne Fin)
    Dim P As Range
    'déclare la variable PL (PLage)
     
    Set O = Worksheets("Feuil3")
    'définit l'onglet O
    LD = O.Range("A1").End(xlDown).Row + 1
    'définit la ligne du début LD
    LF = O.Cells(Application.Rows.Count, "A").End(xlUp).Row + 1
    'définit la ligne de fin LF
    Set PL = O.Range(O.Cells(LD, 1), O.Cells(LF, 2))
    'définit la plage PL
    PL.Cut
    'copy la plage PL
    Sheets("Feuil2").Range("A6").Insert Shift:=xlDown
    'insere la plage pL à partir de cellule A6 de l'onglet "Feuil2"
    Sheets("Feuil2").Select
    End Sub
    Mon problème est que je dois rentrer les titres chapitres par chapitres, et que si j'utilise la macro qui fusionne ces deux macro sur le chapitre 1, il se copiera à la bonne place sans problème, en revanche en copiant le chapitre 2, il s’insérera avant le chapitre 1, ce qui pose problème et je ne peux pas demander à tous ceux qui utiliseront cette macro de l'utiliser en prenant les chapitres de manière décroissante.
    La solution pourrait être de modifier la macro de récupération pour pouvoir rentrer tous les chapitres à la fois, ainsi la macro couper/coller sélectionnerai tous les chapitres en même temps.
    Autre possibilité serait de modifier la macro de récupération pour que les titres s'insèrent directement à la bonne place (A6) seulement en rentrant un autre chapitre, la bonne place ne serait plus A6.

    J'espère avoir été clair dans mes explications,
    Dans l'attente de vous lire,
    Cordialement.

  2. #2
    Membre actif
    Homme Profil pro
    Ingénieur
    Inscrit en
    Septembre 2017
    Messages
    132
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Val d'Oise (Île de France)

    Informations professionnelles :
    Activité : Ingénieur
    Secteur : Industrie

    Informations forums :
    Inscription : Septembre 2017
    Messages : 132
    Par défaut
    Bonjour,

    En ce qui me concerne ce n'est pas clair : tu veux modifier ta macro dynamiquement à chaque exécution ? Ou tu veux que ta macro prenne un argument numéro de chapitre comme paramètre ?

    Le plus simple serait de faire une boucle sur les numéros de chapitre avec un test pour vérifier si le chapitre a été traité ou non par la macro

  3. #3
    Membre chevronné
    Femme Profil pro
    Développeur informatique
    Inscrit en
    Septembre 2012
    Messages
    214
    Détails du profil
    Informations personnelles :
    Sexe : Femme
    Localisation : France, Alpes Maritimes (Provence Alpes Côte d'Azur)

    Informations professionnelles :
    Activité : Développeur informatique

    Informations forums :
    Inscription : Septembre 2012
    Messages : 214
    Par défaut
    Peut-être ?

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
     
    With oWksh
     
        'Copie temporaire
        .cells(1,20).PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
     
        .PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
        Set oRng_table = .Columns(20).Find(oChapitre, LookIn:=xlValues, LookAt:=xlWhole)
        If oRng_table Is Nothing Then
            MsgBox "Le chapitre souhaité n'est pas présent dans le document."
            Exit Sub
        End If
     
       'Copie a la bonne position
       .cells(oRng_table.row,1).select
       .PasteSpecial Format:="Texte", Link:=False, DisplayAsIcon:=False
     
      ' Effacer la copie tempraire
      .cells(1,20).entirecolumn.clear
     ...
     
    End With

Discussions similaires

  1. [XL-2013] Macro pour insertion commentaire dans cellules d'une colonne
    Par delmicman dans le forum Macros et VBA Excel
    Réponses: 3
    Dernier message: 28/03/2016, 14h51
  2. [XL-2010] Macro pour insertion html dans Mail
    Par Nicko29 dans le forum Macros et VBA Excel
    Réponses: 0
    Dernier message: 17/06/2015, 20h27
  3. [XL-2007] Macro pour insertion de photo dans un commentaire
    Par wboyer dans le forum Macros et VBA Excel
    Réponses: 3
    Dernier message: 16/10/2013, 08h24
  4. [XL-2010] Modification de Macro pour un tri de données
    Par davidstarr dans le forum Macros et VBA Excel
    Réponses: 2
    Dernier message: 02/01/2011, 17h39
  5. [XL-2003] Macro pour insertion fichier html dans Mail
    Par jibdu94 dans le forum Macros et VBA Excel
    Réponses: 7
    Dernier message: 21/12/2010, 10h20

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo