Sélection dans un word pour un fichier Excel VBA

Le 26/04/2022 à 15:15

Bonjour , je n'arrive pas à trouver comment copier / coller une zone précise de mon word vers un fichier excel créé

je vous met également le word avec la sélection voulu,

( les cellules que je veux copier sont en Jaune).

Merci de votre réponse.

25test.doc (50.50 Ko)
Sub Refonte_Fichier_AC_Word()

' I-- Déclaration des variables

Dim wb As Workbook 'classeur Excel dans lequel on importe les données

Dim ws As Worksheet 'onglet Excel dans lequel on importe les données

Dim sChemin, sCheminFichier_New As String 'répertoire contenant les fichiers Word

Dim sNomFichier As String 'nom du fichier Word

Dim sNomPlan As String 'nom du plan

Dim WApp As Object, WDoc As Object, WSel As Object 'variable obligatioire pour naviguer entre word et excel

Dim vplan As Integer

' II-- Initialisation des variables

sChemin = "C:\Users\toto\Desktop\TS17\"

sCheminFichier_New = "C:\Users\toto\Desktop\Gamme Excel_AC\"

sNomFichier = Dir(sChemin & "*.doc*") 'pour ouvrir tous les fichiers .doc*. 1er fichier.

Application.ScreenUpdating = False 'ne pas afficher le changement de fichiers Word

'III -- Boucle sur les fichiers

Do While Len(sNomFichier) > 0 'boucle tant qu'elle n'a pas traité tout les fichiers

vplan = Len(sNomFichier) - 4

sNomPlan = Left(sNomFichier, vplan)

Workbooks.Add

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs _

Filename:=sCheminFichier_New & sNomPlan & ".xlsx"

'-------------------boucle création fichier fonctionnel---------

Set wb = Workbooks.Open(sCheminFichier_New & sNomPlan & ".xlsx")

Set ws = wb.Sheets(1)

Set WApp = CreateObject("Word.Application") 'pour créer un objet Word

WApp.Visible = True 'ne pas afficher Word pendant l'exécution

Set WDoc = WApp.Documents.Open(sChemin & sNomFichier) 'ouvre le document Word
'-----------------------Copier / Coller word-----------------

WDoc.tables(1).Selection.Range.Copy
ws.Select
ws.Cells(1, 1).PasteSpecial (x1PasteValues)

'---------------------Fin Copier / Coller Word---------------

WDoc.Close False 'fermer le document Word sans enregistrer

ActiveWorkbook.Close SaveChanges:=True

Application.DisplayAlerts = True

sNomFichier = Dir 'prochain document

SortieNormale:

Application.ScreenUpdating = True

WApp.Quit 'Fermer l'instance de Word

Application.StatusBar = False

Loop

End Sub
Le 27/04/2022 à 05:15

Bonjour,

En phase de développement de votre macro, vous avez plutôt intérêt à référencer Word et basculer en late binding une fois celle-ci mise au point si votre macro doit être distribuée sur des postes avec des versions différentes d'Office. Si vous souhaitez rester en late binding, neutralisez ma ligne Dim Wapp as Word.Application.

Option Explicit

Sub Refonte_Fichier_AC_Word()

' I-- Déclaration des variables

Dim I As Integer, J As Integer, CellEnCours As Integer, ColEnCours As Integer, LigneEnCours As Integer

Dim Wb As Workbook 'classeur Excel dans lequel on importe les données
Dim Ws As Worksheet 'onglet Excel dans lequel on importe les données
Dim sChemin, sCheminFichier_New As String 'répertoire contenant les fichiers Word

Dim sNomFichier As String 'nom du fichier Word
Dim sNomPlan As String 'nom du plan
Dim WApp As Word.Application, WDoc As Word.Document 'variable obligatoire pour naviguer entre word et excel
'Dim WApp As Object, WDoc As Object, WSel As Object 'variable obligatoire pour naviguer entre word et excel
Dim vplan As Integer

    ' II-- Initialisation des variables

    sChemin = ActiveWorkbook.Path & "\"                 '"C:\Users\toto\Desktop\TS17\"
    sCheminFichier_New = ActiveWorkbook.Path & "\"      ' "C:\Users\toto\Desktop\Gamme Excel_AC\"
    sNomFichier = Dir(sChemin & "*.doc*")               'pour ouvrir tous les fichiers .doc*. 1er fichier.

    'Application.DisplayAlerts = False

    Set WApp = CreateObject("Word.Application") 'pour créer un objet Word
    Set WSel = WApp.Selection
    WApp.Visible = True 'ne pas afficher Word pendant l'exécution

    'III -- Boucle sur les fichiers

    Do While Len(sNomFichier) > 0 'boucle tant qu'elle n'a pas traité tout les fichiers

       vplan = Len(sNomFichier) - 4
       sNomPlan = Left(sNomFichier, vplan)

       Set Wb = Workbooks.Add
       Wb.SaveAs Filename:=sCheminFichier_New & sNomPlan & ".xlsx"
       Set Ws = Wb.Sheets(1)
       ColEnCours = 1
       LigneEnCours = 2

       Set WDoc = WApp.Documents.Open(sChemin & sNomFichier) 'ouvre le document Word

       With WDoc
            With .Tables(1).Range
                 CellEnCours = 36
                 For J = 1 To 14
                     For I = CellEnCours To CellEnCours + 2
                         .Cells(I).Range.Copy
                         Ws.Cells(LigneEnCours, ColEnCours).PasteSpecial xlPasteValues
                         ColEnCours = ColEnCours + 1
                     Next I
                     CellEnCours = CellEnCours + 15
                     LigneEnCours = LigneEnCours + 1
                     ColEnCours = 1
                 Next J
             End With
        End With

        WDoc.Close False 'fermer le document Word sans enregistrer
        Set WDoc = Nothing: Set Ws = Nothing

        Wb.Close SaveChanges:=True
        Set Wb = Nothing

        sNomFichier = Dir 'prochain document

    Loop

    WApp.Quit 'Fermer l'instance de Word
    Set WApp = Nothing: Set WSel = Nothing

End Sub
18arkantos-2022-04-27-ex-p-word.xlsm (44.94 Ko)
Le 27/04/2022 à 08:25

Bonjour , merci de votre réponse , mais le problème c'est que faire cette méthode sur un fichier était ma première option sauf qu'il y en a 2600 et faire faire des allez-retours continue d'un word à excel pour chaque valeur créer l'erreur 1004 , ce que j'aimerais c'est savoir si c 'était possible de déterminer une sélection et de faire un seule copier coller que faire du copier coller par cellules .

Merci de votre réponse.

Le 27/04/2022 à 08:29

Vous avez des erreurs avec le code que je vous ai transmis ?

Le 27/04/2022 à 08:32

oui j'ai cette erreur la :

image
Le 27/04/2022 à 08:33

Il faudrait me transmettre votre fichier Word pour voir.

Le 27/04/2022 à 08:39

Je vous met un fichier word avec uniquement ce que j'ai besoin de copier , le reste n'étant pas important pour le code et permet de garder l'anonymat .

89-g39193ts17-a.zip (9.51 Ko)
Le 27/04/2022 à 08:48

Voilà ce que je récupère :

119-g39193ts17-a.xlsx (8.99 Ko)

Dans le code, les lignes avec les variables WdSel sont à neutraliser.

Sub Refonte_Fichier_AC_Word()

' I-- Déclaration des variables

Dim I As Integer, J As Integer, CellEnCours As Integer, ColEnCours As Integer, LigneEnCours As Integer

Dim Wb As Workbook 'classeur Excel dans lequel on importe les données
Dim Ws As Worksheet 'onglet Excel dans lequel on importe les données
Dim sChemin, sCheminFichier_New As String 'répertoire contenant les fichiers Word

Dim sNomFichier As String 'nom du fichier Word
Dim sNomPlan As String 'nom du plan
Dim WApp As Word.Application, WDoc As Word.Document 'variable obligatoire pour naviguer entre word et excel
'Dim WApp As Object, WDoc As Object, WSel As Object 'variable obligatoire pour naviguer entre word et excel
Dim vplan As Integer

    ' II-- Initialisation des variables

    sChemin = ActiveWorkbook.Path & "\"                 '"C:\Users\toto\Desktop\TS17\"
    sCheminFichier_New = ActiveWorkbook.Path & "\"      ' "C:\Users\toto\Desktop\Gamme Excel_AC\"
    sNomFichier = Dir(sChemin & "*.doc*")               'pour ouvrir tous les fichiers .doc*. 1er fichier.

    'Application.DisplayAlerts = False

    Set WApp = CreateObject("Word.Application") 'pour créer un objet Word
   ' Set WSel = WApp.Selection
    WApp.Visible = True 'ne pas afficher Word pendant l'exécution

    'III -- Boucle sur les fichiers

    Do While Len(sNomFichier) > 0 'boucle tant qu'elle n'a pas traité tout les fichiers

       vplan = Len(sNomFichier) - 4
       sNomPlan = Left(sNomFichier, vplan)

       Set Wb = Workbooks.Add
       Wb.SaveAs Filename:=sCheminFichier_New & sNomPlan & ".xlsx"
       Set Ws = Wb.Sheets(1)
       ColEnCours = 1
       LigneEnCours = 2

       Set WDoc = WApp.Documents.Open(sChemin & sNomFichier) 'ouvre le document Word

       With WDoc
            With .Tables(1).Range
                 CellEnCours = 36
                 For J = 1 To 14
                     For I = CellEnCours To CellEnCours + 2
                         .Cells(I).Range.Copy
                         Ws.Cells(LigneEnCours, ColEnCours).PasteSpecial xlPasteValues
                         ColEnCours = ColEnCours + 1
                     Next I
                     CellEnCours = CellEnCours + 15
                     LigneEnCours = LigneEnCours + 1
                     ColEnCours = 1
                 Next J
             End With
        End With

        WDoc.Close False 'fermer le document Word sans enregistrer
        Set WDoc = Nothing: Set Ws = Nothing

        Wb.Close SaveChanges:=True
        Set Wb = Nothing

        sNomFichier = Dir 'prochain document

    Loop

    WApp.Quit 'Fermer l'instance de Word
    Set WApp = Nothing ': Set WSel = Nothing

End Sub
Le 27/04/2022 à 09:08

j'ai la même erreur 1004 après avoir copier coller deux cellules

Le 27/04/2022 à 09:24

Avec le fichier que vous m'avez envoyé ?

Le 27/04/2022 à 09:29

oui ce fichier même

Le 27/04/2022 à 11:16

Essayez ce nouveau code :

Option Explicit

Sub Refonte_Fichier_AC_Word()

' I-- Déclaration des variables

Dim I As Integer, J As Integer, CellEnCours As Integer, ColEnCours As Integer, LigneEnCours As Integer, NbLignes As Integer

Dim Wb As Workbook 'classeur Excel dans lequel on importe les données
Dim Ws As Worksheet 'onglet Excel dans lequel on importe les données
Dim sChemin, sCheminFichier_New As String 'répertoire contenant les fichiers Word

Dim sNomFichier As String 'nom du fichier Word
Dim sNomPlan As String 'nom du plan
Dim WApp As Word.Application, WDoc As Word.Document 'variable obligatoire pour naviguer entre word et excel
'Dim WApp As Object, WDoc As Object, WSel As Object 'variable obligatoire pour naviguer entre word et excel
Dim vplan As Integer

    ' II-- Initialisation des variables

    sChemin = ActiveWorkbook.Path & "\"                 '"C:\Users\toto\Desktop\TS17\"
    sCheminFichier_New = ActiveWorkbook.Path & "\"      ' "C:\Users\toto\Desktop\Gamme Excel_AC\"
    sNomFichier = Dir(sChemin & "*.doc*")               'pour ouvrir tous les fichiers .doc*. 1er fichier.

    Application.DisplayAlerts = False

    Set WApp = CreateObject("Word.Application") 'pour créer un objet Word
   ' Set WSel = WApp.Selection
    WApp.Visible = True 'ne pas afficher Word pendant l'exécution

    'III -- Boucle sur les fichiers

    Do While Len(sNomFichier) > 0 'boucle tant qu'elle n'a pas traité tout les fichiers

       vplan = Len(sNomFichier) - 4
       sNomPlan = Left(sNomFichier, vplan)

       Set Wb = Workbooks.Add
       Set Ws = Wb.Sheets(1)

       ColEnCours = 1
       LigneEnCours = 2

       Set WDoc = WApp.Documents.Open(sChemin & sNomFichier) 'ouvre le document Word

       WDoc.Tables(1).Range.Copy
       With Ws
            .Activate
            .Cells(LigneEnCours, ColEnCours).Select
            .Paste
       End With

        WDoc.Close False 'fermer le document Word sans enregistrer
        Set WDoc = Nothing

        MiseEnFormeOnglet Ws

       Wb.SaveAs Filename:=sCheminFichier_New & sNomPlan & ".xlsx"

        Wb.Close SaveChanges:=True
        Set Wb = Nothing
        Set Ws = Nothing

        sNomFichier = Dir 'prochain document

    Loop

    WApp.Quit 'Fermer l'instance de Word
    Set WApp = Nothing ': Set WSel = Nothing

    Application.DisplayAlerts = True

    MsgBox "Fin du traitement !", vbInformation

End Sub

Sub MiseEnFormeOnglet(ByVal Sh As Worksheet)

Dim DerniereLigne As Integer

  With Sh
       With .Cells
            .Borders.LineStyle = xlNone
             With .Interior
                  .Pattern = xlNone
                  .TintAndShade = 0
                  .PatternTintAndShade = 0
             End With
             With .Font
                  .Name = "Calibri"
                  .Size = 9
             End With
       End With
       .Rows("1:7").Clear
       With .Columns("D:U")
             .Clear
             .HorizontalAlignment = xlLeft
             .WrapText = False
       End With
       With .Columns("B:C")
             .WrapText = False
             .HorizontalAlignment = xlLeft
             .EntireColumn.AutoFit
       End With
       .Cells.EntireRow.RowHeight = 12

   End With

End Sub
Le 27/04/2022 à 14:04

j'ai trouvé une solution à mon problèmes voici le code et j'aimerais savoir si il existe un moyen de prendre un autre tableau dans word car j'arrive pas à en selectionner en changeant juste le numéro de tables

et aussi si il existait une commande pour détecter une forme dans une cellule de tableau

Merci

Sub Refonte_Fichier_AC_Word()

' I-- Déclaration des variables
    Dim wb As Workbook                                  'classeur Excel dans lequel on importe les données
    Dim ws As Worksheet                                 'onglet Excel dans lequel on importe les données
    Dim sChemin, sCheminFichier_New As String                                'répertoire contenant les fichiers Word
    Dim sNomFichier As String                           'nom du fichier Word
    Dim sNomPlan As String                                'nom du plan
    Dim test1 As String
    Dim WApp As Object, WDoc As Object, WSel As Object  'variable obligatioire pour naviguer entre word et excel
    Dim vplan, i, l, t, Vop As Integer

    ' II-- Initialisation des variables
    sChemin = "C:\Users\toto\Desktop\TS17\"
    sCheminFichier_New = "C:\Users\toto\Desktop\Gamme Excel_AC\"
    sNomFichier = Dir(sChemin & "*.doc*")       'pour ouvrir tous les fichiers .doc*. 1er fichier.

    Application.ScreenUpdating = False                  'ne pas afficher le changement de fichiers Word

    'III -- Boucle sur les fichiers
Do While Len(sNomFichier) > 0                           'boucle tant qu'elle n'a pas traité tout les fichiers
    'III-2 -- mise en place de la base de données
        vplan = Len(sNomFichier) - 4
        sNomPlan = Left(sNomFichier, vplan)
    Workbooks.Add
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs _
    Filename:=sCheminFichier_New & sNomPlan & ".xlsx"
'-------------------boucle création fichier fonctionnel---------

    Set wb = Workbooks.Open(sCheminFichier_New & sNomPlan & ".xlsx")
    Set ws = wb.Sheets(1)

    Set WApp = CreateObject("Word.Application")         'pour créer un objet Word
    WApp.Visible = True                                 'ne pas afficher Word pendant l'exécution

        Set WDoc = WApp.Documents.Open(sChemin & sNomFichier)   'ouvre le document Word
'-----------------------Copier / Coller word-----------------
        Cells(1, 10) = WDoc.tables(1).Cell(5, 1).Range
        test1 = Left(Cells(1, 10), Len(Cells(1, 10)) - 1)
        Vop = Len(test1)
        Cells(1, 10).ClearContents
i = 2
l = 7
For t = 1 To 2
Stp = 0
If Vop > 3 Then
            Do While Stp < 30 'condition de sécurité la valeur peut être changer si besoin
            Cells(1, 1) = "Côte demandée"
            Cells(1, 2) = "Moyen"

                ws.Cells(i, 1) = WDoc.tables(t).Cell(l, 1).Range
                ws.Cells(i, 1) = Left(ws.Cells(i, 1), Len(ws.Cells(i, 1)) - 1)
                ws.Cells(i, 2) = WDoc.tables(t).Cell(l, 2).Range
                ws.Cells(i, 2) = Left(ws.Cells(i, 2), Len(ws.Cells(i, 2)) - 1)

                    If (IsEmpty(ActiveCell)) Then
                        Stp = Stp + 1
                        i = i - 1
                    ElseIf Cells(i, 1) = Cells(i - 1, 1) Then
                        Stp = Stp + 3
                        Cells(i, 1).ClearContents
                        Cells(i, 2).ClearContents
                        i = i - 1
                    End If
                    l = l + 1
                    i = i + 1

            Loop
Else
            Do While Stp < 30 'condition de sécurité la valeur peut être changer si besoin
            Cells(1, 1) = "OP"
            Cells(1, 2) = "Côte demandée"
            Cells(1, 3) = "Moyen"

                ws.Cells(i, 1) = WDoc.tables(t).Cell(l, 1).Range
                ws.Cells(i, 1) = Left(ws.Cells(i, 1), Len(ws.Cells(i, 1)) - 1)
                ws.Cells(i, 2) = WDoc.tables(t).Cell(l, 2).Range
                ws.Cells(i, 2) = Left(ws.Cells(i, 2), Len(ws.Cells(i, 2)) - 1)
                ws.Cells(i, 3) = WDoc.tables(t).Cell(l, 3).Range
                ws.Cells(i, 3) = Left(ws.Cells(i, 3), Len(ws.Cells(i, 3)) - 1)
                    If (IsEmpty(ActiveCell)) Then
                        Stp = Stp + 1

                    ElseIf Cells(i, 2) = Cells(i - 1, 2) Then
                        Stp = Stp + 30
                        Cells(i, 1).ClearContents
                        Cells(i, 2).ClearContents
                        Cells(i, 3).ClearContents
                        i = i - 1

                    End If

                        l = l + 1
                        i = i + 1
            Loop
End If
Next t
'---------------------Fin Copier / Coller Word---------------
        WDoc.Close False                'fermer le document Word sans enregistrer

        ActiveWorkbook.Close SaveChanges:=True
        Application.DisplayAlerts = True

sNomFichier = Dir               'prochain document
SortieNormale:
Application.ScreenUpdating = True
WApp.Quit                           'Fermer l'instance de Word
Application.StatusBar = False
Loop
End Sub
119-g39259t08-b.zip (16.07 Ko)
Le 27/04/2022 à 14:14

Le dernier code fourni ne fonctionnait pas ?

Le 27/04/2022 à 14:18

J'ai chercher entre mon dernier message et le tien et j'ai trouvé une partie de ma solution parceque je peut traiter que 80% des fichiers

je l'ai pas tester a vrai dire car ma solution fonctionne sans aucun bug , mais je te remercie du temps que tu m'accordes.

Rechercher des sujets similaires à "selection word fichier vba"