Helpmij.nl
Helpmij.nl
Helpmij.nl
Steun Helpmij.nl! Klik hier     Computerprobleem? Klik hier!

Quote

Pagina 1 van 2 1 2 LaatsteLaatste
Weergeven resultaten 1 tot 20 van 22

Onderwerp: Mbv VBA meerdere documenten samenvoegen

  1. #1
    Junior Member
    Geregistreerd
    11 November 2019
    Vraag is opgelost

    Mbv VBA meerdere documenten samenvoegen

    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

  2. #2
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    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 aangepast door edmoor : 26 March 2020 om 15:23
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

  3. #3
    Junior Member
    Geregistreerd
    11 November 2019
    Dank je wel Edmoor voor je reactie.
    Sorry, maar ik snap nu niet waar jouw code dan moet plaatsen?

  4. #4
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    Ik zie net pas dat je vraag voor Word is.
    Zal ik vanavond even naar kijken.
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

  5. #5
    Junior Member
    Geregistreerd
    11 November 2019
    Dat zou fantastisch zijn.
    Alvast bedankt

  6. #6
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    Probeer het eens zo:
    Code:
    Sub VoegDocumentenSamen()
        Dim strPath, strTargetDocument, strDocName(200) As String
        Dim intDocCounter As Integer
        
        strPath = GetFolder '"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
    
    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
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

  7. #7
    Junior Member
    Geregistreerd
    11 November 2019
    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.

  8. #8
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    Ik denk dat je wat vergeet:
    Code:
    Documents.Open (strPath & "\" & strDocName(n))
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

  9. #9
    Junior Member
    Geregistreerd
    11 November 2019
    Ik krijg helaas dezelfde foutmelding

  10. #10
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    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.
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

  11. #11
    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
        
        strPath = GetFolder & "\"
    Let wel: de voorgestelde wijziging uit reactie #8 moet dan genegeerd worden.
    Succes !

  12. #12
    Junior Member
    Geregistreerd
    11 November 2019
    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.

  13. #13
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    Plaats een voorbeeld documentje en vertel er bij wat precies je bedoeling is.
    Kunnen we even mee kijken
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

  14. #14
    Junior Member
    Geregistreerd
    11 November 2019
    Ik heb nog geen documentje.
    Het is eigenlijk een "tussenstap" waar je een selectie kan maken van de aanwezige word documenten

    HTML Code:
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    
    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

  15. #15
    Junior Member
    Geregistreerd
    11 November 2019
    Sorry voor de kleur.. dom van mij

  16. #16
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    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.
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

  17. #17
    Junior Member
    Geregistreerd
    11 November 2019
    Alvast bedankt

  18. #18
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    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 '"D:\TESTOMGEVING\"
        
        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
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

  19. #19
    Junior Member
    Geregistreerd
    11 November 2019
    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

  20. #20
    Tera Honourable Senior Member edmoor's avatar
    Geregistreerd
    8 September 2000
    Locatie
    Zuid-Holland
    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.
    "It's hardware that makes a machine fast. It's software that makes a fast machine slow. "
    Op rechtstreekse vragen via email of privébericht reageer ik niet. Daar is het forum voor.
    Lees ook: http://www.helpmij.nl/forum/announcement.php?f=5

Berichtenregels

  • U mag geen nieuwe vragen starten.
  • U mag niet reageren op berichten.
  • U mag geen bijlagen versturen.
  • U mag uw berichten niet bewerken.
  •  
Helpmij.nl
Helpmij.nl

Helpmij.nl en business

Partners
Sponsoren