Automatické otevření wordu a spuštění macra, uložení a zavření – Visual Basic – Fórum – Programujte.com

Potřeboval bych poradit mám cca 200 souborů s příponou .doc v jedném adresáři a potřeboval bych macro na to aby mě to automaticky otevřelo soubor a zaplo druhé macro které pozmění něco ve wordu a následně uložilo a tak by to pokračovalo do konce složky. používám word 2013

zkoušel jsem toto:

Private Sub Document_Open()

Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Superscript = True
        .Subscript = False
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Superscript = False
        .Subscript = False
    End With
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = "^t"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

ActiveDocument.Save
ActiveDocument.Close

End Sub

jenže to nefunguje když otevřu najednou 50 souborů je problém s ukládáním vždy se to kousne myslím že to otevře víc souborů najednou a pak neví co zavírat.

také jsem to zkoušel z exelu že bych to spustil a ono by mě to krásně celou složku otevřelo, změnilo a  zavřelo

viz

Private Sub CommandButton9_Click()

ChDrive "F"

adresar = "F:\Marek aktualizace"
ChDir adresar
SouboryKtere = Dir("*.*")
ListBox1.Clear
Do While SouboryKtere <> ""
    ListBox1.AddItem SouboryKtere
    SouboryKtere = Dir

'Dim wdApp As Object
    Dim wdDoc As Object
    Set wdApp = CreateObject("Word.application")
    
    Set wdDoc = wdApp.Documents.Open _
    (Filename:=adresar & "\" & SouboryKtere)

' put your code here for working with Word
' This is Word VBA code, not Excel code

Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Superscript = True
        .Subscript = False
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Superscript = False
        .Subscript = False
    End With
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = "^t"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    wdDoc.Close savechanges:=True
    Set wdDoc = Nothing
    wdApp.Quit
    Set wdApp = Nothing

Loop
End Sub

ale tady je problém s otevíráním souborů ve wordu děkuji za pomoc

#1 Marek Sz
už jsem na to přišel možná to někomu pomůže :)

Private Sub CommandButton21_Click()
Dim SouboryKtere As String

ChDrive "E"
adresar = "E:\Marek aktualizace"
ChDir adresar
SouboryKtere = Dir("*.doc")
ListBox21.Clear
Do While SouboryKtere <> ""
'otevře soubor

Documents.Open FileName:=adresar & "\" & SouboryKtere 'kontrola spuštění wordu

'zpracuje macro

'zde vložit macro jaké chcete provést v souborech

'provedeno macro

   ActiveDocument.Save    'uloží doubor
   ActiveDocument.Close 'zavře soubor

  
    ListBox21.AddItem SouboryKtere
    SouboryKtere = Dir

Loop
End Sub

#2 Marek Sz

Nevím z jakého důvodu mi to přestalo pracovat ale možná že tam chybí nějaké to

 If SouboryKtere = Konec Then Exit Do 

Dělá mi to že se mě to nezastaví funguje mi to dobře ale když to přijde na konec tak se mě to nezastaví a pokračuje znova nevím několikrát jsem to zkoušel a fungovalo to dobře zastavilo se to na konci ale teď to pořád jede a nezastaví jestli by někdo věděl proč se to nezastaví? 

#3 Marek Sz
už jsem na to přišel souborů musí být cca min 10 když jsou dva tak to zlobí a nezastaví se to