Plusieurs fichiers Word vers Excel

Bonjour,

M'est avis que tu devrais publier tes macros ici. (Par copier-coller dans un
message, pas en fichier-joint), ou mettre des fichiers exemples sur
htt://www.cjoint.com et nous donner le lien que cjoint va fournir.

Ceci dit, une question qui m'est venue à l'esprit : pourquoi passer par Word
avant ?


"KaZaLas" <dursty76@yahoo.fr> a écrit dans le message de
news:1118076913.398503.6130@g44g2000cwa.googlegroups.com...
Bonjour à tous,

Je dois récupérer dans un fichier Word des donnéespour les mettre
dans un fichier Excel. Je copie mes données dans Word. Je les colle
dans Excel. Je lance une petite macro qui récupère mes données, les
mets en forme et les colle en feuille 2. Jusqu'ici pas de gros
problèmes.

Sauf que j'ai plus de 1000 fichiers Word à traiter. Certes, les
données sont toujours présentées de la même façon dans tous les
fichiers Word, mais 1000 copier/coller ça fait 999 de trop !!

Bref, j'ai développé une petite macro dans word qui va chercher dans
chaque fichier les données qui m'intéressent et qui les colle dans un
fichier word à part (doc1.doc). Ensuite, j'ai amélioré ma macro
Excel pour qu'elle aille automatiquement ouvrir doc1.doc, qu'elle copie
les données, qu'elle les colle dans Excel et qu'elle fasse le reste
(mise en forme + collage feuille 2). Tourjours est-il que je dois quand
même ouvrir un par un mes 1000 fichiers word, lancer ma macro word,
retourner sous excel et lancer ma macro excel. C'est par encore ça ?

Je sollicite donc très humblement vos avis éclairés pour obtenir une
solution, voire des codes. Peut-être pouvoir sélectionner directement
depuis excel chaque fichier word ?

Merci par avance pour vos réponses de spécialistes !

A+

Merci pour ta réponse
En fait, je passe par word pour pouvoir sélectionner le fichier qui
m'interesse et extraire les données vers un autre fichier word via une
macro. ça fait beaucoup d'intermédiaires tout ça.
Il faudrait que j'arrive via la macro excel à piloter le tout
c'est-à-dire sélectionner le fichier word, aller chercher l'info qui
m'intéresse et la copier dans excel. C'est là tout mon problème.

Et voici la macro dans Excel

Sub Referencer()

Dim DocWord As Word.Document
Dim AppWord As Word.Application
Set AppWord = New Word.Application
AppWord.ShowMe
AppWord.Visible = True

'Ouvre le document Word (Fichier.doc) et effectue une copie des
données

Set DocWord = AppWord.Documents.Open("C:Documents and
SettingsPropriétaireBureauDoc1.doc", ReadOnly:=True)
With AppWord
.Selection.WholeStory
.Selection.Copy
End With

' Copie des données dans Excel

ThisWorkbook.Worksheets("Feuil1").Paste

' Fermeture de Word

AppWord.Application.Quit
Application.CutCopyMode = False

' mise en forme du collage

Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select

Range("A1:A6").Select
Selection.ClearContents
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft

Range("A2").Select
Selection.Cut
Selection.End(xlUp).Select
Selection.End(xlToRight).Select
Selection.End(xlToLeft).Select

Range("B1").Select
ActiveSheet.Paste
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.Cut
Selection.End(xlUp).Select

Range("C1").Select
ActiveSheet.Paste
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.Cut
Selection.End(xlUp).Select

Range("D1").Select
ActiveSheet.Paste
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.Cut
Selection.End(xlUp).Select

Range("E1").Select
ActiveSheet.Paste
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.Cut
Selection.End(xlUp).Select

Range("A1:E5").Select
With Selection.Font
.Name = "Times New Roman"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

Selection.Font.Bold = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With


' collage en feuille 2

Range("A1:E1").Select
Selection.Copy
Worksheets("Feuil2").Select
Cells([E65536].End(xlUp).Row + 1, 5).PasteSpecial xlPasteAll

Rows("1:65536").Select
Selection.RowHeight = 15
Columns("E:I").Select
With Selection.Font
.Name = "Arial"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

' affichage en feuille 1 du prochain fichier à rechercher

Range("A1").Select
Selection.Copy
Worksheets("Feuil1").Select
Range("B1").Select
Selection.PasteSpecial xlPasteAll

Worksheets("Feuil2").Select
Range("C1:D1").Select
Selection.Copy
Worksheets("Feuil1").Select
Range("C1:D1").Select
Selection.PasteSpecial xlPasteAll

Worksheets("Feuil2").Select
Cells([E65536].End(xlUp).Row + 1, 1).Select
Selection.Copy
Worksheets("Feuil1").Select
Range("B2").Select
Selection.PasteSpecial xlPasteAll

Worksheets("Feuil2").Select
Cells([E65536].End(xlUp).Row + 1, 3).Select
Selection.Copy
Worksheets("Feuil1").Select
Range("C2").Select
Selection.PasteSpecial xlPasteAll

Worksheets("Feuil2").Select
Cells([E65536].End(xlUp).Row + 1, 4).Select
Selection.Copy
Worksheets("Feuil1").Select
Range("D2").Select
Selection.PasteSpecial xlPasteAll

Range("A2").Select
ActiveCell.FormulaR1C1 = "NEXT :"
With ActiveCell.Characters(Start:=1, Length:=6).Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A2").Select
Selection.Font.Bold = True
Selection.Font.ColorIndex = 3

Range("B2:D2").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With

Range("E1").Select
Selection.ClearContents
Range("A1").Select
Selection.ClearContents

ActiveWorkbook.Save


End Sub



Et la macro word :
Sub Referencier()
'
Selection.Find.Execute
With Selection.Find
.Text = "texte à rechercher"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdWord, Count:=8, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Selection.Copy

' cree le fichier word et y copier les données

Documents.Add DocumentType:=wdNewBlankDocument
Selection.PasteAndFormat (wdPasteDefault)
ActiveDocument.SaveAs FileName:="Doc1.doc",
FileFormat:=wdFormatDocument, _
LockComments:=False, Password:="", AddToRecentFiles:=True,
WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False,
SaveAsAOCELetter:= _
False
ActiveWindow.Close

Application.WindowState = wdWindowStateNormal
Selection.HomeKey Unit:=wdStory
End Sub


Merci par avance !

Bonjour,

À défaut de bien saisir le véritable besoin, quelques questions et
commentaires:

Tourjours est-il que je dois quand
même ouvrir un par un mes 1000 fichiers word, lancer ma macro word,
retourner sous excel et lancer ma macro excel. C'est par encore ça ?

Faut-il comprendre que tu ouvres chaque fichier Word "à la main" avec
Fichier-Ouvrir ?

Si oui, tu peux faire ouvrir tes fichiers "en masse" par macro:

Par exemple, cette macro ouvre, du moins un principe, tous les fichiers doc
dans "mes documents". Aucun contrôle pour savoir si cela sature la mémoire
ou non ou si cela fait planter la machine.

Cela fait que serait quelque peu prudent de fermer toutes les autres
applications avant d'essayer cela, ou du moins de copier une nombre limité
de fichiers dans un dossier de test avant de lancer.

Mais, je répète : PRUDENCE, PRUDENCE, PRUDENCE.






"KaZaLas" <dursty76@yahoo.fr> a écrit dans le message de
news:1118076913.398503.6130@g44g2000cwa.googlegroups.com...
Bonjour à tous,

Je dois récupérer dans un fichier Word des donnéespour les mettre
dans un fichier Excel. Je copie mes données dans Word. Je les colle
dans Excel. Je lance une petite macro qui récupère mes données, les
mets en forme et les colle en feuille 2. Jusqu'ici pas de gros
problèmes.

Sauf que j'ai plus de 1000 fichiers Word à traiter. Certes, les
données sont toujours présentées de la même façon dans tous les
fichiers Word, mais 1000 copier/coller ça fait 999 de trop !!

Bref, j'ai développé une petite macro dans word qui va chercher dans
chaque fichier les données qui m'intéressent et qui les colle dans un
fichier word à part (doc1.doc). Ensuite, j'ai amélioré ma macro
Excel pour qu'elle aille automatiquement ouvrir doc1.doc, qu'elle copie
les données, qu'elle les colle dans Excel et qu'elle fasse le reste
(mise en forme + collage feuille 2).
Je sollicite donc très humblement vos avis éclairés pour obtenir une
solution, voire des codes. Peut-être pouvoir sélectionner directement
depuis excel chaque fichier word ?

Merci par avance pour vos réponses de spécialistes !

A+

Bonjour,

Avant de lire cela, j'ai envoyé un autre message pour ouvrir tous les
documents Word d'un dossier. Je vais regarder tout cela au cours des
prochains jours.


"KaZaLas" <dursty76@yahoo.fr> a écrit dans le message de
news:1118082914.054297.76840@z14g2000cwz.googlegroups.com...
Et voici la macro dans Excel

Sub Referencer()

Dim DocWord As Word.Document
Dim AppWord As Word.Application
Set AppWord = New Word.Application
AppWord.ShowMe
AppWord.Visible = True

'Ouvre le document Word (Fichier.doc) et effectue une copie des
données

Set DocWord = AppWord.Documents.Open("C:Documents and
SettingsPropriétaireBureauDoc1.doc", ReadOnly:=True)
With AppWord
.Selection.WholeStory
.Selection.Copy
End With

' Copie des données dans Excel

ThisWorkbook.Worksheets("Feuil1").Paste

' Fermeture de Word

AppWord.Application.Quit
Application.CutCopyMode = False

' mise en forme du collage

Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select

Range("A1:A6").Select
Selection.ClearContents
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft

Range("A2").Select
Selection.Cut
Selection.End(xlUp).Select
Selection.End(xlToRight).Select
Selection.End(xlToLeft).Select

Range("B1").Select
ActiveSheet.Paste
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.Cut
Selection.End(xlUp).Select

Range("C1").Select
ActiveSheet.Paste
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.Cut
Selection.End(xlUp).Select

Range("D1").Select
ActiveSheet.Paste
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.Cut
Selection.End(xlUp).Select

Range("E1").Select
ActiveSheet.Paste
Selection.End(xlToLeft).Select
Selection.End(xlDown).Select
Selection.Cut
Selection.End(xlUp).Select

Range("A1:E5").Select
With Selection.Font
.Name = "Times New Roman"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

Selection.Font.Bold = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With


' collage en feuille 2

Range("A1:E1").Select
Selection.Copy
Worksheets("Feuil2").Select
Cells([E65536].End(xlUp).Row + 1, 5).PasteSpecial xlPasteAll

Rows("1:65536").Select
Selection.RowHeight = 15
Columns("E:I").Select
With Selection.Font
.Name = "Arial"
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

' affichage en feuille 1 du prochain fichier à rechercher

Range("A1").Select
Selection.Copy
Worksheets("Feuil1").Select
Range("B1").Select
Selection.PasteSpecial xlPasteAll

Worksheets("Feuil2").Select
Range("C1:D1").Select
Selection.Copy
Worksheets("Feuil1").Select
Range("C1:D1").Select
Selection.PasteSpecial xlPasteAll

Worksheets("Feuil2").Select
Cells([E65536].End(xlUp).Row + 1, 1).Select
Selection.Copy
Worksheets("Feuil1").Select
Range("B2").Select
Selection.PasteSpecial xlPasteAll

Worksheets("Feuil2").Select
Cells([E65536].End(xlUp).Row + 1, 3).Select
Selection.Copy
Worksheets("Feuil1").Select
Range("C2").Select
Selection.PasteSpecial xlPasteAll

Worksheets("Feuil2").Select
Cells([E65536].End(xlUp).Row + 1, 4).Select
Selection.Copy
Worksheets("Feuil1").Select
Range("D2").Select
Selection.PasteSpecial xlPasteAll

Range("A2").Select
ActiveCell.FormulaR1C1 = "NEXT :"
With ActiveCell.Characters(Start:=1, Length:=6).Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A2").Select
Selection.Font.Bold = True
Selection.Font.ColorIndex = 3

Range("B2:D2").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With

Range("E1").Select
Selection.ClearContents
Range("A1").Select
Selection.ClearContents

ActiveWorkbook.Save


End Sub



Et la macro word :
Sub Referencier()
'
Selection.Find.Execute
With Selection.Find
.Text = "texte à rechercher"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

Selection.HomeKey Unit:=wdLine
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdWord, Count:=8, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Selection.Copy

' cree le fichier word et y copier les données

Documents.Add DocumentType:=wdNewBlankDocument
Selection.PasteAndFormat (wdPasteDefault)
ActiveDocument.SaveAs FileName:="Doc1.doc",
FileFormat:=wdFormatDocument, _
LockComments:úlse, Password:="", AddToRecentFiles:=True,
WritePassword _
:="", ReadOnlyRecommended:úlse, EmbedTrueTypeFonts:úlse, _
SaveNativePictureFormat:úlse, SaveFormsData:úlse,
SaveAsAOCELetter:= _
False
ActiveWindow.Close

Application.WindowState = wdWindowStateNormal
Selection.HomeKey Unit:=wdStory
End Sub


Merci par avance !