Sammentæl sideantal på tværs af dokumenter

Det kan du gøre, hvis du opretter et hoveddokument, og tilknytter de øvrige dokumenter som underdokumenter.

Jeg har lavet en lille makro som kan det (dog foreløbig uden opdating):

Sub IndsætFilnavne()
With Application.FileSearch
    .NewSearch
    .LookIn = "C:\WordDocs"
    .FileName = "*.doc"
    .Execute
    .FileType = msoFileTypeWordDocuments
   
    For i = 1 To .FoundFiles.Count
       
        navn = .FoundFiles(i)
        Application.Documents.Open FileName:=navn, Visible:=False
        Application.Documents(navn).Activate
        Antal = Selection.Information(wdNumberOfPagesInDocument)
        Application.Documents(navn).Close False
       
        Selection.TypeText navn
        Selection.TypeText Text:=vbTab
        Selection.TypeText Antal
        Selection.TypeParagraph
    Next
End With
       
End Sub

rvm: MEGA COOL!

Hvis det så kunne være auto-opdaterende så var det endnu mere genialt!

Kan man lave det så det er C:\WordDocs INCL. undermapper ?

Jeg arbejder på sagen *S*

Indsæt en tabel med 2 kolonner

Placer markøren i tabellen og kør makroen:

Sub IndsætFilnavne()

Selection.Tables(1).Select

If Err Then
    MsgBox "Du står ikke i en tabel!"
    Exit Sub
End If

Selection.Tables(1).Select
Selection.Delete Unit:=wdCharacter, Count:=1

ActiveDocument.Tables(1).Rows(1).Cells(1).Select


With Application.FileSearch
    .NewSearch
    .SearchSubFolders = True
    .LookIn = "C:\WordDocs"
    .FileName = "*.doc"
    .Execute
    .FileType = msoFileTypeWordDocuments
   
    Selection.TypeText "Dokument"
    Selection.MoveRight Unit:=wdCell
    Selection.TypeText "Antal sider"
    Selection.MoveRight Unit:=wdCell
   
    For i = 1 To .FoundFiles.Count
       
        navn = .FoundFiles(i)
        Application.Documents.Open FileName:=navn, Visible:=False
        Application.Documents(navn).Activate
        antal = Selection.Information(wdNumberOfPagesInDocument)
        Application.Documents(navn).Close False
       
        Selection.TypeText navn
        Selection.MoveRight Unit:=wdCell
        Selection.TypeText antal
        Selection.MoveRight Unit:=wdCell
       
        Ialt = Ialt + antal
    Next
   
    Selection.TypeText "Sider i alt"
    Selection.MoveRight Unit:=wdCell
    Selection.TypeText Ialt
End With
       
End Sub

Når du vil opdatere stiller du dig igen i tabellen og kører makroen *S*

Det er du da temmelig hård til!

Mange tak for hjælpen!

En lille forbedring:

Erstat:

Selection.Tables(1).Select

If Err Then
    MsgBox "Du står ikke i en tabel!"
    Exit Sub
End If

med:

on error resume next
Selection.Tables(1).Select

If Err Then
    MsgBox "Du står ikke i en tabel!"
    Exit Sub
End If
en error goto 0

Det er bare lidt fejlhåndtering *S*

Lige en sidste ting...

Kan man få den til at lave en 3. kolonne med antallet af tegn?

Lav tabellen om til at have 3 kolonner.

Kør denne makro:

Sub IndsætFilnavne()

On Error Resume Next
Selection.Tables(1).Select

If Err Then
    MsgBox "Du står ikke i en tabel!"
    Exit Sub
End If
On Error GoTo 0

Selection.Tables(1).Select
Selection.Delete Unit:=wdCharacter, Count:=1

ActiveDocument.Tables(1).Rows(1).Cells(1).Select


With Application.FileSearch
    .NewSearch
    .SearchSubFolders = True
    .LookIn = "C:\WordDocs"
    .FileName = "*.doc"
    .Execute
    .FileType = msoFileTypeWordDocuments
   
    Selection.TypeText "Dokument"
    Selection.MoveRight Unit:=wdCell
    Selection.TypeText "Antal sider"
    Selection.MoveRight Unit:=wdCell
    Selection.TypeText "Antal tegn"
    Selection.MoveRight Unit:=wdCell
   
    For i = 1 To .FoundFiles.Count
        navn = .FoundFiles(i)
        Application.Documents.Open FileName:=navn, Visible:=False
        Application.Documents(navn).Activate
        antal = Selection.Information(wdNumberOfPagesInDocument)
        tegn = ActiveDocument.BuiltInDocumentProperties("Number of Characters")
        Application.Documents(navn).Close False
       
        Selection.TypeText navn
        Selection.MoveRight Unit:=wdCell
        Selection.TypeText antal
        Selection.MoveRight Unit:=wdCell
        Selection.TypeText tegn
        Selection.MoveRight Unit:=wdCell
       
        IaltSider = IaltSider + antal
        IaltTegn = IaltTegn + tegn
    Next
   
    Selection.TypeText "Sider i alt"
    Selection.MoveRight Unit:=wdCell
    Selection.TypeText IaltSider
    Selection.MoveRight Unit:=wdCell
    Selection.TypeText IaltTegn
   
End With
       
End Sub

Takker!

:-)