programme de copier plusieurs tableaux de plusieurs word vers plusieurs xls

nelamari

XLDnaute Nouveau
Bonsoir,
je viens de solliciter votre aide sur le programme suivant:

Sub Vers_Word()
Dim NDF As String
Dim Temp As String
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim i As Integer
Dim j As Integer

For j = 1 To 4
NDF = ActiveWorkbook.Path & "\j.doc"
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
Temp = ActiveWorkbook.Path & "\j.xls"
Application.DisplayAlerts = False
Workbooks.Open ActiveWorkbook.Path & "\" & "\j.xls"
For i = 1 To 4
WordDoc.Tables(i).Range.Copy
Sheets(i).Activate
Range("A1").Select
ActiveSheet.Paste
Next i
Next j
WordDoc.Close False
WordApp.Quit
End Sub

mon programme ouvre le fichier word nommé 01.doc et copie les 4 tableaux à partir du fichier 01.doc vers excel 01.xls.
Ce que je souhaite faire c'est de copier les 4 tableaux:
01.doc vers 01.xls
02.doc vers 02.xls
jusqu'au
100.doc vers 100.xls

merci d'avance
 

gilbert_RGI

XLDnaute Barbatruc
Re : programme de copier plusieurs tableaux de plusieurs word vers plusieurs xls

Bonjour,

comme ceci
attention les doc's et xls's doivent être dans le même répertoire ainsi que le fichier contenant cette macro
Code:
Sub Vers_Word()
    Dim NDF As String
    Dim Temp As String
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim i As Integer
    Dim j As Integer
    Dim Chemin
    Chemin = ThisWorkbook.path & "\"
    For j = 1 To 4 'mettre ici 100 à la place de 4 si cent fichiers il y a !!!!!!
        NDF = Chemin & j & ".doc"
        Set WordApp = CreateObject("Word.Application")
        WordApp.Visible = True
        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
        Workbooks.Open Chemin & j & ".xls"
        For i = 1 To 4 'nombre de tableaux
            WordDoc.Tables(i).Range.Copy
            Sheets(1).Activate
            derl = Workbooks(j & ".xls").Worksheets(1).Range("A36536").End(xlUp).Row + 2
            Workbooks(j & ".xls").Worksheets(1).Cells(derl, 1).Select
            ActiveSheet.Paste
        Next i
        Application.DisplayAlerts = False
        Workbooks(j & ".xls").SaveAs Filename:=j & ".xls"
        WordDoc.Close
        WordApp.Quit
        Application.DisplayAlerts = True
    Next j
    MsgBox "terminé"
    Workbooks.Close
End Sub
 
Dernière édition:

nelamari

XLDnaute Nouveau
Re : programme de copier plusieurs tableaux de plusieurs word vers plusieurs xls

merci ça marche nikel, voila le nouveau code

Sub BlocCopyWord()
Dim NDF As String
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim i As Integer
Dim j As Integer
Dim Chemin As Variant
Chemin = ThisWorkbook.Path & "\"
For j = 1 To 16 'mettre ici 100 à la place de 4 si cent fichiers il y a !!!!!!
NDF = Chemin & j & ".doc"
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
Workbooks.Open Chemin & j & ".xls"
For i = 1 To 4 'nombre de tableaux
WordDoc.Tables(i).Range.Copy
Sheets(i).Activate
Range("A1").Select
ActiveSheet.Paste
Next i
Application.DisplayAlerts = False
Workbooks(j & ".xls").SaveAs Filename:=j & ".xls"
WordDoc.Close
WordApp.Quit
Application.DisplayAlerts = True
Next j
MsgBox "terminé"
Workbooks.Close
End Sub
 

Discussions similaires