• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Tabellen uit Word2010 inlezen in Excel2010

Status
Niet open voor verdere reacties.
P

Pieter671

Gebruiker
Lid geworden
26 jun 2015
Berichten
105
Hallo,

Ik heb een Word2010 bestand met diverse tabellen (zie bijlage voor een vereenvoudigde versie).

Deze tabellen wil ik graag via een macro automatisch kopiëren naar / in Excel 2010.

De 'eisen', grijs, naar tabblad 1 en de 'wensen', groen, naar tabblad 2 in Excel.


Heeft iemand een idee hoe dit in VBA is op te zetten?


Bekijk bijlage Voorbeeld.docx
 
Ik heb zeker een idee. Creëer een Excel document met 3 tabs. Noem deze als volgt:
"Eisen"
"Wensen"
"Log"

Deze laatste heb ik toegevoegd, omdat ik een check uitvoer op de eerste letter (E=Eis, W=Wens). Ik weet niet of er meer varianten voorkomen waardoor je anders zaken gaat missen. Vandaar.

Creëer een headerregel op iedere pagina, bv.:
Cel A1: Table #
Cel B1: Item #
Cel C1: Omschrijving

Plak de volgende code in VBA en run deze. Je krijgt de mogelijkheid om het gewenste document te selecteren:
Code: 
Sub ImportWordTables()

    Dim wdDoc               As Object
    Dim wdFileName          As Variant
    Dim TableNo, iTable     As Integer
    Dim iRow, iCol          As Long
    Dim iEis, iWens, iLog   As Long
   
    wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _
        "Browse for file containing table to be imported")
         
    If wdFileName = False Then Exit Sub
   
    Set wdDoc = GetObject(wdFileName)
   
    iEis = 1
    iWens = 1
    iLog = 1
    
    With wdDoc
        TableNo = wdDoc.tables.Count
        If TableNo = 0 Then
            MsgBox "This document contains no tables", _
                vbExclamation, "Import Word Table"
        End If
      
        For iTable = 1 To TableNo
            With .tables(iTable)
                If Left(.cell(1, 1).Range.ListFormat.ListString, 1) = "E" Then
                    iEis = iEis + 1
                    ActiveWorkbook.Worksheets("Eisen").Activate
                    Cells(iEis, "A") = iTable
                    Cells(iEis, "B") = WorksheetFunction.Clean(.cell(1, 1).Range.ListFormat.ListString)
                    Cells(iEis, "C") = WorksheetFunction.Clean(.cell(1, 2).Range.Text)
                ElseIf Left(.cell(1, 1).Range.ListFormat.ListString, 1) = "W" Then
                    iWens = iWens + 1
                    ActiveWorkbook.Worksheets("Wensen").Activate
                    Cells(iWens, "A") = iTable
                    Cells(iWens, "B") = WorksheetFunction.Clean(.cell(1, 1).Range.ListFormat.ListString)
                    Cells(iWens, "C") = WorksheetFunction.Clean(.cell(1, 2).Range.Text)
                Else
                    iLog = iLog + 1
                    ActiveWorkbook.Worksheets("Log").Activate
                    Cells(iLog, "A") = iTable
                    Cells(iLog, "B") = WorksheetFunction.Clean(.cell(1, 1).Range.ListFormat.ListString)
                    Cells(iLog, "C") = WorksheetFunction.Clean(.cell(1, 2).Range.Text)
                End If
            End With
        Next iTable
    End With
   
    Set wdDoc = Nothing
   
End Sub

Succes!
 
Vanuit Word naar Excel, waarin een werkboek open staat:

Code: 
Sub M_snb()
   With GetObject(, "Excel.application")
        For j = 1 To ActiveDocument.Tables.Count
            ActiveDocument.Tables(j).Select
            Selection.Copy
            .activeworkbook.sheets(1).Cells(.Rows.Count, 1).End(-4162).Offset(5).Select
            .activeworkbook.sheets(1).Paste
        Next
   End With
End Sub
 
@snb: Het zal vast korter kunnen, maar in jouw versie wordt niet weggeschreven naar verschillende tabbladen. Ook ging ik uit van een oplossing in Excel gezien het forum. Ik vind het wel altijd interessant om de verschillende invalshoeken te zien, waarvoor mijn dank.

Ik ben benieuwd of de vraagsteller met één van beide versies uit de voeten kan.
 
@Peter, @snb,

Bedankt voor jullie reacties.
Het is inderdaad de bedoeling om vanuit Excel de macro te starten.
De opbouw van Peter sluit meer aan bij mijn behoefte. De toevoeging van het LOG-tabblad spreekt mij er aan.

De macro werkt goed, er zijn echter nog wel een paar aanvullende kenmerken.


De "eisen" en "wensen" zijn standaard 1 rij en 2 kolommen.
In Word kan de tweede kolom uit meerdere regels en alinea's bestaan.

Zijn deze ook in deze opmaak over te zetten naar Excel?
Nu wordt alles achter elkaar beplakt.

N.B.: Als ik dit handmatig doe en ik plak deze in Excel in één cel, dan worden de zinnen gekopieerd naar meerdere cellen. Als is het plak in de formule balk, dan komt de inhoud incl. enters in één cel te staan.

De overige tabellen in Word kunnen uit meerdere kolommen en rijen bestaan.

Is het mogelijk om in het log tabblad alle overige tabellen in hun geheel over te zetten naar Excel?
De opmaakt van de overige cellen behoeft niet bewaard te blijven.

Ik heb een tweede voorbeeld-bestand bijgevoegd.

Bekijk bijlage Voorbeeld 2.docx

Pieter
 
Dat was wat lastiger. "Mijn" methode plakt idd. de regels achter elkaar, dus ik moest iets anders verzinnen. Ik heb hierbij een hulpsheet geïntroduceerd. Volgens mij wordt je tweede voorbeeld naar wens verwerkt. Zo niet dan lees ik dat graag ...

Creëer een 4e tab, genaamd "Hulp". En pas de code als volgt aan:
Code: 
Option Explicit

Sub ImportWordTables()

    Dim wdDoc                   As Object
    Dim wdFileName              As Variant
    Dim TableNo, iTable, i      As Integer
    Dim iRow, numRows           As Long
    Dim wb                      As Workbook
    Dim ws                      As Worksheet
    Dim sHulp                   As String
    Dim EisofWens               As Boolean
   
    wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _
        "Browse for file containing table to be imported")
         
    If wdFileName = False Then Exit Sub
   
    Set wdDoc = GetObject(wdFileName)
   
    With wdDoc
        TableNo = wdDoc.tables.Count
        If TableNo = 0 Then
            MsgBox "This document contains no tables", _
                vbExclamation, "Import Word Table"
        End If
      
        Set wb = ActiveWorkbook
        wb.Sheets("Eisen").Range("A2:C200").Clear
        wb.Sheets("Wensen").Range("A2:C200").Clear
        wb.Sheets("Log").Range("A2:C200").Clear
      
        For iTable = 1 To TableNo
            With .tables(iTable)
                Set ws = wb.Sheets("Hulp")                              ' Selecteer de hulpsheet
                ws.Activate                                             ' Activeer de hulpsheet
                ws.Range("A1:B11").Clear                                ' Maak de range op de hulpsheet schoon
                ws.Range("A1").Select
                .Range.Copy                                             ' Kopieer de Word tabel
                ws.Cells(1, 1).Activate                                 ' Selecteer cel A1
                ws.Paste                                                ' Plak de tabel op de hulpsheet
                numRows = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row    ' Bepaal aantal regels wens/ eis
                sHulp = Cells(1, 2).Value                               ' Selecteer de eerste regel
                If numRows > 1 Then                                     ' Voeg de losse regels samen
                    For i = 1 To numRows
                        sHulp = sHulp & Chr(10) & Cells(i, 2).Offset(1, 0).Value
                    Next i
                End If
                If Left(.Cell(1, 1).Range.ListFormat.ListString, 1) = "E" Then
                    Set ws = wb.Sheets("Eisen")
                    EisofWens = True
                ElseIf Left(.Cell(1, 1).Range.ListFormat.ListString, 1) = "W" Then
                    Set ws = wb.Sheets("Wensen")
                    EisofWens = True
                Else
                    Set ws = wb.Sheets("Log")
                    EisofWens = False
                End If
                ws.Activate
                iRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
                If EisofWens = True Then
                    ws.Cells(iRow, 1).Value = iTable
                    ws.Cells(iRow, 2).Value = .Cell(1, 1).Range.ListFormat.ListString
                    ws.Cells(iRow, 3).Value = sHulp
                Else
                    ws.Cells(iRow, 1).Activate
                    ws.Paste
                End If
            End With
        Next iTable
    End With
   
    Set wdDoc = Nothing
   
End Sub
 
Peter,

Alles verloopt naar wens. Ziet en mooi uit. Top.
Ik ben hier enorm mee geholpen.

Bedankt.

Pieter
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan