Finition de programme Importation du nom du documents

Le 25/06/2019 à 15:24

Bonjour,

J'ai un petit soucis pour finir un programme.

Le but de celui ci est de parcourir un fichier de récupérer de chaque document word un certain tableau.

Le programme juste en dessous marche parfaitement

Sub IMPORT_TAB() 'Variable Dim WordApp As Object, WordDoc As Object Dim arrFileList As Variant, FileName As Variant Dim tableNo%, tableStart%, tableTot%, Target As Range Application.ScreenUpdating = False 'Fige l'affichage durant l'execution de la macro pour plus de rapidité Application.DisplayAlerts = False 'Evite d'avoir des pop-up d'Alertes Application.StatusBar = " LOADING turn, turn, turn, turn,......" 'Sélection multiple de .docm dans un dossier Sheets("TABLE").Select arrFileList = _ Application.GetOpenFilename("Fichier(s) Word (*.doc; *.docm; *.docx;),*.doc;*.docm", 2, "Choix du dossier d'import", , True) If Not IsArray(arrFileList) Then Exit Sub Set WordApp = CreateObject("Word.Application") WordApp.Visible = False Set Target = Range("B1") <= [b]'ICI CA CONTINUE DE COLLER EN A1 POUR LE PREMIER TABLEAU[/b] 'Parcours des fichiers For Each FileName In arrFileList Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True) With WordDoc tableNo = WordDoc.Tables.Count tableTot = WordDoc.Tables.Count If tableNo = 0 Then MsgBox WordDoc.Name & "ne contient aucun tableau", vbExclamation, "Importation Tableaux Word" ElseIf tableNo > 1 Then End If 'Copie du 5ème tableau sur excel With .Tables(5) .Range.Copy Target.Activate ActiveSheet.Paste Set Target = Target.Offset(0, columnOffset:=5) Compteur = Compteur + 1 End With .Close False End With Next FileName End Sub

Je vais mettre un exemple du résultat en pièce jointe.

Mon souhait est quand je récupère un tableau je souhaiterais aussi mettre le nom du document correspondant.

La position :

- soit dans la ligne 1 à gauche ou droite du tableau

- soit baisser tous les tableaux d'un cran et de le mettre au dessus.

Je ne sais pas quel est le plus simple.

En pièce jointe le tableau excel FORUM vous montre juste l'allure des tableaux et les docs word + excel test permet de faire un test si besoin

Merci à toutes les personnes pouvant m'apporter de l'aide.

Cordialement.

5word-1.docx (16.13 Ko)
4word-2.docx (16.21 Ko)
4word-4.docx (16.20 Ko)
6test.xlsm (23.00 Ko)
5forum.xlsm (24.88 Ko)
Le 26/06/2019 à 03:14

Bonjour,

à tester,

Sub IMPORT_TAB()
'Variable
Dim WordApp As Object, WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo%, tableStart%, tableTot%, Target As Range

Application.ScreenUpdating = False 'Fige l'affichage durant l'execution de la macro pour plus de rapidité
Application.DisplayAlerts = False 'Evite d'avoir des pop-up d'Alertes
Application.StatusBar = " LOADING turn, turn, turn, turn,......"

'Sélection multiple de .docm dans un dossier
Sheets("TABLE").Select
arrFileList = _
Application.GetOpenFilename("Fichier(s) Word (*.doc; *.docm; *.docx;),*.doc;*.docm", 2, "Choix du dossier d'import", , True)
If Not IsArray(arrFileList) Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set Target = Range("B2")
Target.Activate

'Parcours des fichiers
For Each FileName In arrFileList
    Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
    With WordDoc
        tableNo = WordDoc.Tables.Count
        tableTot = WordDoc.Tables.Count
        If tableNo = 0 Then
        MsgBox WordDoc.Name & "ne contient aucun tableau", vbExclamation, "Importation Tableaux Word"
        ElseIf tableNo > 1 Then
        End If

            'Copie du 5ème tableau sur excel
            With .Tables(1)
                .Range.Copy
                Target.Activate
                ActiveSheet.Paste
            End With

            Target.Offset(-1, 0) = WordDoc.Name
            Set Target = Target.Offset(0, columnOffset:=6)
            Target.Activate
            Compteur = Compteur + 1

        .Close False
    End With
Next FileName

'On appelle la fonction
'Call Harmonisation
ActiveWorkbook.Save

'Pour faire propre
Application.ScreenUpdating = True
Application.DisplayAlerts = True
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing

'Visuel
MsgBox "There are " & Compteur & " WordDocs" & Chr(10) & "KEEP THIS NUMBER IN MIND !!!"
Compteur = 0
Application.StatusBar = " IMPORT realized "
End Sub
Le 26/06/2019 à 08:45

Merci pour ta réponse tout marche sauf pour le premier tableau.

Je ne comprends pas il ne veut pas se coller en target B1 donc il ne descend pas d'une case et le titre n'est pas collé.

Je vais tester différentes choses et on verra.

Je te tiens au courant.

Le 26/06/2019 à 11:11

Pile quand je suis arrivés à adapter la macro, on me change mon objectif.

Le concept est le même il faut récupérer les noms de fichiers et les mettre à la suite dans la même ligne mais d'une autre page.

Donc j'ai crée un Target2 que j'ai set dans la feuille voulu.

Sheets("COMPARAISON").Select Set Target2 = Range("D1")

Mais le problème c'est que ca marche pour le premier doc mais ensuite les noms se mettent dans la feuille TABLE.

J'ai l'impression que mon TARGET2 s'active dans la feuille TABLE.

Je vous mets le programme modifier

Sub IMPORT_TAB() 'Variable Dim WordApp As Object, WordDoc As Object Dim arrFileList As Variant, FileName As Variant Dim tableNo%, tableStart%, tableTot% Dim Target As Range, Target2 As Range Application.ScreenUpdating = False 'Fige l'affichage durant l'execution de la macro pour plus de rapidité Application.DisplayAlerts = False 'Evite d'avoir des pop-up d'Alertes Application.StatusBar = " LOADING turn, turn, turn, turn,......" 'Sélection multiple de .docm dans un dossier Sheets("COMPARAISON").Select Set Target2 = Range("D1") 'NOUVELLE TARGET ICI Sheets("TABLE").Select arrFileList = _ Application.GetOpenFilename("Fichier(s) Word (*.doc; *.docm; *.docx;),*.doc;*.docm", 2, "Choix du dossier d'import", , True) If Not IsArray(arrFileList) Then Exit Sub Set WordApp = CreateObject("Word.Application") WordApp.Visible = False Set Target = Range("A1") 'Parcours des fichiers For Each FileName In arrFileList Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True) With WordDoc tableNo = WordDoc.Tables.Count tableTot = WordDoc.Tables.Count If tableNo = 0 Then MsgBox WordDoc.Name & "ne contient aucun tableau", vbExclamation, "Importation Tableaux Word" ElseIf tableNo > 1 Then End If 'Copie du 5ème tableau sur excel With .Tables(5) .Range.Copy Target.Activate ActiveSheet.Paste Set Target = Target.Offset(0, columnOffset:=5) End With Target2.Offset(0, 0) = WordDoc.Name 'CETTE PARTIE A MODIFIE Set Target2 = Target.Offset(0, columnOffset:=1) Target2.Activate 'Call Harmonisation_2 Compteur = Compteur + 1 .Close False End With Next FileName 'On appelle la fonction Call Harmonisation ActiveWorkbook.Save 'Pour faire propre Application.ScreenUpdating = True Application.DisplayAlerts = True WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing Sheets("LAUNCH").Select 'Visuel MsgBox "There are " & Compteur & " WordDocs" Compteur = 0 Application.StatusBar = " IMPORT realized " End Sub

Je remets aussi l'excel pour test qui fonctionne avec les fichiers word mis précédemment.

Cordialement

1test.xlsm (21.86 Ko)
Le 26/06/2019 à 15:07

re,

à tester,

4nathg31-test.xlsm (22.45 Ko)

voici ce que j'obtiens,

nathg31 test
Le 26/06/2019 à 15:16

C'est exactement ceci merci de ton aide.

Rechercher des sujets similaires à "finition programme importation nom documents"