Mbv VBA meerdere documenten samenvoegen

Status
Niet open voor verdere reacties.
J

Jeannette2509

Gebruiker
Lid geworden
11 nov 2019
Berichten
39
Ik wil graag meerdere word documenten samenvoegen met behulp van VBA.
Dit is wat ik tot nu toe heb

Code: 
Sub VoegDocumentenSamen()
Dim strPath, strTargetDocument, strDocName(200) As String
Dim intDocCounter As Integer

strPath = "D:\TESTOMGEVING\"

strTargetDocument = "Samengevoegd[" & Date & "].docx"
intDocCounter = 1
strDocName(intDocCounter) = Dir(strPath & "*.docx", vbNormal)   'Eerste *.docx
Do While strDocName(intDocCounter) <> ""
    If strDocName(intDocCounter) <> "." And strDocName(intDocCounter) <> ".." Then
        intDocCounter = intDocCounter + 1
    End If
    strDocName(intDocCounter) = Dir
Loop
intDocCounter = intDocCounter - 1 'want de laatste is leeg

'Nu heb ik een array met alle Worddocumenten in de dir strPath

Documents.Add
For n = 1 To intDocCounter
    Documents.Open (strPath & strDocName(n))
    Selection.WholeStory
    Selection.Copy
    ActiveDocument.Close savechanges:=False
    Selection.Paste
Next n
ActiveDocument.SaveAs FileName:=strPath & strTargetDocument
End Sub

Ik zou graag:

- een dialoogvenster zoals ‘Bestand Open’ en er een specifieke map kan worden aangewezen (niet openen) en bevestigen met ‘ok‘.
dit ipv vaste pad strPath = "D:\TESTOMGEVING"

- een formuliertje willen maken dat wordt gevuld met een lijst uit deze array met vinkjes etc.

Hoop dat iemand mij kan helpen. Alvast bedankt
 
Daar kan je deze functie voor gebruiken:
Code: 
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function

Aanroep:
Bestand = GetFolder()
 
Laatst bewerkt:
Dank je wel Edmoor voor je reactie.
Sorry, maar ik snap nu niet waar jouw code dan moet plaatsen?
 
Ik zie net pas dat je vraag voor Word is.
Zal ik vanavond even naar kijken.
 
Probeer het eens zo:
Code: 
Sub VoegDocumentenSamen()
    Dim strPath, strTargetDocument, strDocName(200) As String
    Dim intDocCounter As Integer
    
    strPath = GetFolder [COLOR="#008000"]'"D:\TESTOMGEVING\"[/COLOR]
    
    strTargetDocument = "Samengevoegd[" & Date & "].docx"
    intDocCounter = 1
    strDocName(intDocCounter) = Dir(strPath & "*.docx", vbNormal)   'Eerste *.docx
    Do While strDocName(intDocCounter) <> ""
        If strDocName(intDocCounter) <> "." And strDocName(intDocCounter) <> ".." Then
            intDocCounter = intDocCounter + 1
        End If
        strDocName(intDocCounter) = Dir
    Loop
    intDocCounter = intDocCounter - 1 [COLOR="#008000"]'want de laatste is leeg[/COLOR]
    
   [COLOR="#008000"] 'Nu heb ik een array met alle Worddocumenten in de dir strPath[/COLOR]
    
    Documents.Add
    For n = 1 To intDocCounter
        Documents.Open (strPath & strDocName(n))
        Selection.WholeStory
        Selection.Copy
        ActiveDocument.Close savechanges:=False
        Selection.Paste
    Next n
    ActiveDocument.SaveAs FileName:=strPath & strTargetDocument
End Sub

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
Bedankt Edmoor,

Ik heb het geprobeerd, maar krijg een foutmelding 5174 dat bestand niet gevonden is:

Code: 
Documents.Open (strPath & strDocName(n))

en kom dan ook niet verder.
 
Ik denk dat je wat vergeet:
Code: 
Documents.Open (strPath & [COLOR="#FF0000"]"\" &[/COLOR] strDocName(n))
 
Je hebt toch wel deze functie er bij gezet neem ik aan?
Code: 
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function

Onder de End Sub van je bestaande code.
 
Hoi,

De meeste pluimen binnen dit draadje horen uiteraard bij edmoor toe te komen.
Met deze minimale aanpassing aan zijn code zal het vermoedelijk wel lukken (hieronder enkel het gedeelte tot waar de wijziging zit):
Code: 
Sub VoegDocumentenSamen()
    Dim strPath, strTargetDocument, strDocName(200) As String
    Dim intDocCounter As Integer
    
    [COLOR="#0000FF"]strPath = GetFolder & "\"[/COLOR]
Let wel: de voorgestelde wijziging uit reactie #8 moet dan genegeerd worden.
Succes !
 
FANTASTISCH - het werkt.

Beide heel erg bedankt voor jullie hulp!!


Had nog een vervolg vraag:
- een formuliertje dat wordt gevuld met een lijst uit deze array met vinkjes etc.

maar natuurlijk alleen als dit een niet al te grote opgave is, want hier ben ik al super blij mee.
 
Plaats een voorbeeld documentje en vertel er bij wat precies je bedoeling is.
Kunnen we even mee kijken :)
 
Ik heb nog geen documentje.
Het is eigenlijk een "tussenstap" waar je een selectie kan maken van de aanwezige word documenten

HTML: 
Sub VoegDocumentenSamen()
    Dim strPath, strTargetDocument, strDocName(200) As String
    Dim intDocCounter As Integer
    
    strPath = GetFolder & "\"
    
    strTargetDocument = "Samengevoegd[" & Date & "].docx"
    intDocCounter = 1
    strDocName(intDocCounter) = Dir(strPath & "*.docx", vbNormal)   'Eerste *.docx
    Do While strDocName(intDocCounter) <> ""
        If strDocName(intDocCounter) <> "." And strDocName(intDocCounter) <> ".." Then
            intDocCounter = intDocCounter + 1
        End If
        strDocName(intDocCounter) = Dir
    Loop
    intDocCounter = intDocCounter - 1
    
    
 [COLOR="#FF0000"] [B]  'Nu heb ik een array met alle Worddocumenten in de dir strPath
    'Als er nu eerst een formulier wordt weergegeven met de aanwezige word documenten
    'welke je dan kan aanvinken om te laten samenvoegen[/B][/COLOR]
    
    
    Documents.Add
    For n = 1 To intDocCounter
        Documents.Open (strPath & "\" & strDocName(n))
        Selection.WholeStory
        Selection.Copy
        ActiveDocument.Close savechanges:=False
        Selection.Paste
    Next n
    ActiveDocument.SaveAs FileName:=strPath & strTargetDocument
End Sub

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
Ik denk dat ik weetr wat je bedoelt en zal daar vanavond even naar kijken.

Wat die kleur betreft, gebruik niet de HTML tags maar de CODE (#) tags.
 
Doe het eens zo. Je kan meerdere documenten selecteren door de Ctrl toets ingedrukt te houden.
De array wordt dan automatisch gevuld waarna je eigen stukje er mee aan de slag kan.
Dit is ongetest, dat mag je zelf doen :)
Maar de bedoeling lijkt me duidelijk.

Code: 
Sub VoegDocumentenSamen()
    Dim strPath, strTargetDocument
    Dim strDocName() As String
    Dim intDocCounter As Integer
    
    strPath = GetFolder [COLOR="#008000"]'"D:\TESTOMGEVING\"[/COLOR]
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .InitialFileName = strPath
        .Title = "Selecteer document(en)"
        .Filters.Clear
        .Filters.Add "Word bestanden", "*.doc*"
        If .Show = True Then
            For i = 1 To .SelectedItems.Count
                ReDim Preserve strDocName(i - 1)
                strDocName(i - 1) = .SelectedItems(i)
            Next i
            intDocCounter = i
        End If
    End With
    
    Documents.Add
    strTargetDocument = "Samengevoegd[" & Date & "].docx"
    For n = 1 To intDocCounter
        Documents.Open (strPath & strDocName(n))
        Selection.WholeStory
        Selection.Copy
        ActiveDocument.Close savechanges:=False
        Selection.Paste
    Next n
    ActiveDocument.SaveAs FileName:=strPath & strTargetDocument
End Sub

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Selecteer een folder"
        .AllowMultiSelect = False
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function
 
Edmoor bedankt, maar helaas lukt het me niet.

Ik krijg o.a. de volgende foutmelding op
Code: 
ReDim Preserve strDocName(i - 1)

Compileerfout - Het aantal dimensies van de matrix is al bepaald

Ook krijg ik nu foutmelding op:
Code: 
Documents.Open (strPath & strDocName(n))

Zou je nog even willen kijken?
Alvast bedankt
 
In mij voorbeeld wordt de dimensie niet van tevoren bepaald.
De code die ik plaatste geeft geen enkele foutmelding.

Je hebt nu dingen eruit gekopieerd en in je eigen code geplakt.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan