wordfiles tabellen omzetten naar Excelfiles

Status
Niet open voor verdere reacties.
C

Cootje2002

Gebruiker
Lid geworden
12 mei 2013
Berichten
12
Ik heb een aantal word documenten (tabel als formulier opgemaakt) in een directory staan die ik wil omzetten naar gelijk genaamde losse excel files.
Ik wil dat de gebruiker de keuze krijgt de word files te selecteren waarna deze worden omgezet. Het omzetten heb ik al ergens opgesnort
wie kan mij helpen?


Code: 
Sub tabel_Data_Word_naar_Excel()

With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
    FileToOpen = Application.GetOpenFilename _
    (Title:="Please choose a file to import", _
    FileFilter:="Word Files *.docx* (*.docx*),")
    ''
    If FileToOpen = False Then
    
        MsgBox "Geen bestand gekozen.", vbExclamation, "Vergissing???"
    Exit Sub

    End If

'We declare object variables for Word Application and document
Dim WdApp As Object, wddoc As Object
'Declare a string variable to access our Word document
Dim strDocName As String
'Error handling
On Error Resume Next
'Activate Word it is already open
Set WdApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
'Create a Word application if Word is not already open
Set WdApp = CreateObject("Word.Application")
End If
WdApp.Visible = True

'strDocName = "C:\our-inventory\inventory.docx"""

strDocName = FileToOpen

'Check relevant directory for relevant document
'If not found then inform the user and close program
If Dir(strDocName) = "" Then
    MsgBox "The file " & strDocName & vbCrLf & _
    "was not found in the folder path" & vbCrLf & _
    "C:\our-inventory\.", _
vbExclamation, _
"Sorry, that document name does not exist."""
Exit Sub
End If

WdApp.Activate

Set wddoc = WdApp.Documents(strDocName)

If wddoc Is Nothing Then Set wddoc = WdApp.Documents.Open(strDocName)
wddoc.Activate
'define variables to access the tables in the word document
Dim Tble As Integer
Dim rowWd As Long
Dim colWd As Integer
Dim x As Long, y As Long
x = 1
y = 1
With wddoc
Tble = wddoc.tables.Count
If Tble = 0 Then

MsgBox "No Tables found in the Word document", vbExclamation, "No Tables to Import"
Exit Sub
End If
'start the looping process to access tables and their rows, columns
For i = 1 To Tble
With .tables(i)
For rowWd = 1 To .Rows.Count
For colWd = 1 To .Columns.Count
Cells(x, y) = WorksheetFunction.Clean(.cell(rowWd, colWd).Range.Text)
'Access next column
y = y + 1

Next colWd
'go to next row and start from column 1
y = 1
x = x + 1

Next rowWd
End With

Next
End With
'don't save the word
wddoc.Close Savechanges:=False

'Quit Word
WdApp.Quit
'Release system memory allocated to the 2 object variables
Set wddoc = Nothing
Set WdApp = Nothing
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
End With
 
Laatst bewerkt:
Waarom heb je die wanhopige code niet gefatsoeneerd ??

Code: 
Sub M_snb()
   With Application.FileDialog(1)
       .Filters.Add "Wordbestanden", "*.doc*", 1
       If .Show Then
          With GetObject(.SelectedItems(1))
             If .tables.Count > 0 Then
                .tables(1).Range.Copy
                ThisWorkbook.Sheets(1).Paste ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
             End If
             .Close 0
          End With
       End If
    End With
End Sub
 
Beste SNB,

Hartelijk dank voor je reactie.
Jouw code ziet er idd veel netter uit, echter komt er niets in excel te staan.
De word tabel wordt wel gekopieerd want wanneer ik cntr+V druk wordt hij in excel geplakt en zie ik alles staan.
 
Kijk eens onderaan in het werkblad.
 
Je melding is leeg.
Ik zie helaas jouw bestand niet....

Controleren wat de code doet doe je stap voor stap met de F8 knop in de vbeditor.
 
ik ben een stapje verder. Ik werk in een citrix omgeving. daar werk de code helaas niet.
Lokaal echter gebeurt er wel iets.
Na het opstarten van de code opent de verkenner en kan ik de wordfiles selecteren die ik omgezet wil hebben (test met 2 files).
Wanneer ik dat gedaan heb wordt de 1ste file gekopieerd naar excel. de tweede file gebeurt niets mee (niets wat ik zie).
Het is de bedoeling dat ik nadat ik de code start, er een selectie van MSword bestanden wordt gevraagd, deze (formulieren/tabellen)worden omgezet naar seperate excelbestanden en dat er per MSword document er een gelijknamig excelbestand wordt opgeslagen.

ter extra info. er wordt gebruik gemaakt van office 2010.
SNB hartelijk dank voor je moeite, ben er erg blij mee.
 
Mijn code loopt via Citrix ook vlekkelings.
Als je mijn code niet gebruikt, maar aangepaste, dan zou het kunnen liggen aan .....
 
Ik gebruik alleen jouw code. Ik heb 2 voorbeeld word documenten toegevoegd.
Ben benieuwd of die bij jou wel werken.
 

Bijlagen

  • Test 1.doc
    37 KB · Weergaven: 25
  • Test 2.doc
    37 KB · Weergaven: 30
De macro staat toch in een Excel bestand ?
Plaats die.
 
Ik begrijp niet waarom het bij mij niet werkt zoals bij jou.
ik stuur het excelbestand mee waar de macro in staat.
wanneer je deze uitvoert, de twee word documenten selecteert (test1 en test 2), verschijnt alleen het eerste word bestand (test1) in de excelfile.
 

Bijlagen

  • Map2.xlsm
    17,5 KB · Weergaven: 28
Als je meerdere bestanden selecteert en je gebruikt SelectedItems(1) dan gebeurt er natuurlijk alleen iets met het eerste bestand. Zet er een lusje omheen als het om meerdere bestanden gaat. Bv

Code: 
For j = 1 To .SelectedItems.Count
          With GetObject(.SelectedItems(j))
             If .tables.Count > 0 Then
                .tables(1).Range.Copy
               
                ThisWorkbook.Sheets(1).Paste ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1)
             End If
             .Close 0
          End With
       Next j
       End If
 
Beste VenA,
Dit werk inderdaad prima, echter wil ik Word bestanden selecteren, vervolgens worden van deze word bestanden gelijknamige excel bestanden maken.
12 word bestanden, leveren dus 12 excelbestanden op (bij voorkeur automatisch gelijk aan naam van word bestanden.
Word bestand test1.doc wordt opgeslagen als test1.xlsx, test2.doc opgeslagen als test2.xlsx. enz, enz
 
Bestudeer hoe VBA in elkaar zit en je kunt de code zelf maken.
Nu is het teveel 'ik roep, u draait'.
 
SNB,

Ik ben zeker geen expert op VBA gebied. Anders had ik de vraag ook niet gesteld want dan wist ik de antwoorden al.
Dat het bij jou overkomt als "ik roep, u draait" betreur ik want het is niet zo dat ik zelf niets doe.
 
En wat als de .xlsx bestanden al bestaan? Met de macro recorder kan je een heel eind komen.

Probeer het zo maar eens
Code: 
If .tables.Count > 0 Then
    c00 = .Path & "\" & Split(.Name, ".")(0) & ".xlsx"
    .tables(1).Range.Copy
    With Workbooks.Add
        .Sheets(1).Paste .Sheets(1).[A1]
        .SaveAs c00
        .Close
    End With
End If
 
Dit werkt perfect! Indien de bestanden bestaan mogen ze worden overschreven. Daarom de meldingen onderdrukt.
Uiteindelijk is dit het eindresultaat wat (voor mij) werkt.
Hartelijk dank voor je oplossing.


Code: 
With Application
   .DisplayAlerts = False
   .ScreenUpdating = False
   End With
   With Application.FileDialog(1)
       .Filters.Add "Wordbestanden", "*.doc*", 1
       If .Show Then
       
     For j = 1 To .SelectedItems.Count
          With GetObject(.SelectedItems(j))
            If .tables.Count > 0 Then
    c00 = .Path & "\" & Split(.Name, ".")(0) & ".xlsx"
    .tables(1).Range.Copy
        With Workbooks.Add
        .Sheets(1).Paste .Sheets(1).[A1]
        .SaveAs c00
        .Close
        End With
       End If
             .Close 0
          End With
     Next j
       End If
    End With
    With Application
   .DisplayAlerts = True
   .ScreenUpdating = True
    End With
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan