Van Word copy excel en save excel

[greatmaze]

Hallo allemaal,

Ik wil vanuit Word 2010 een 1 waarde 1 keer kopieren naar Excel 2010 in kolom A1 en als die vol is dan naar A2 en na de copy hetzelfde excel bestand weer sluiten en oplsaan.
In onderstaande code lukt de copy paste naar Excel wel, maar hoe zoek ik de volgende lege regel als de erste vol is.
Het sluiten van de applicatie werkt ook, alleen hij heeft dan niets gesaved in het document.
Weet iemand de oplossing.

Sub aaaOpenExcel()
Dim wb As Object
Dim xlsApp As Object
Dim oTable As Table
Dim i As Long
Dim r As Long
Dim strString As String

Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
Set wb = xlsApp.Workbooks.Open("C:\Temp\Test.xlsx")
Set oTable = ActiveDocument.Tables(15)

For i = 1 To oTable.Rows.Count
'De waarde uit de eerste Cell wordt gelezen
strString = oTable.Rows.Item(1).Cells(1).Range
'De check of de cell leeg is
If Strings.Len(strString) > 2 Then
strString = Left(strString, Len(strString) - 1)
'MsgBox (strString)
wb.Worksheets(1).Range("A" & r).Value = strString
End If
Next i

wb.Close SaveChanges:=True
End sub

 

[OctaFish]

Twee dingen: zou je de code willen opmaken met de CODE knop (te vinden in <Ga geavanceerd, of je kunt de tag [ CODE ] codetekst [ /CODE ] ook typen zonder de spaties in de code)? Ten tweede: een voorbeeldje doet wonderen; je wilt neem ik aan toch niet dat we zelf een voorbeeld tekst in elkaar moeten zetten? De typcursus heb ik jaren geleden al gedaan namelijk . Ik besteed mijn tijd liever aan het zoeken naar een antwoord, dan aan nodeloos tekst intypen.

 

[Warme bakkertje]

Probeer eens met deze.

wb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Value = strString

 

[greatmaze]

Thx voor de antwoorden van jullie.

@Warme bakkertje
De code werkt helaas niet, ik moet xlUp en Rows als variabelen declareren van het programma.
Alles gaat dus vanuit Word met VBA voor Word.

@OctaFish
Ik heb geen idee wat voor een voorbeeld ik zou moeten meesturen.
Ik wil gewoon een woord vanuit msWord naar Excel kopieren, dat lukt ook.
Maar nu wil ik als er in het excel bestand in A1 al iets staat dat het dan automatisch in A2 terecht komt. Het probleem is dat het allemaal via Word VBA moet gaan.

Als 2e is dat de code wel het excel document afsluit, maar niet opslaat, terwijl ik dat wel verwacht met SaveAs, dus als ik daarna het bestand weer open, dan is het woord dat ik daarvoor in cel A2 zag staan er niet meer.

 

[Warme bakkertje]

Dit werkt perfect (wel even de verwijzing naar de Excel bibliotheek aanvinken)
Heb even een tabel van 5 rijen, 1 kolom aangemaakt en de waarden worden perfect onder elkaar in het bestand weggeschreven.

Sub aaaOpenExcel()
Dim oTable As Table, i As Long, r As Long, strString As String

Set oTable = ActiveDocument.Tables(1)
r = 1
With CreateObject("Excel.Application")
    .Visible = True
    .Workbooks.Open "G:\Mijn documenten\Map1.xlsm"
    For i = 1 To oTable.Rows.Count
        strString = oTable.Rows.Item(i).Cells(1).Range 'De waarde uit de eerste Cell wordt gelezen
        If Strings.Len(strString) > 2 Then 'De check of de cell leeg is
            strString = Left(strString, Len(strString) - 1)
            'MsgBox (strString)
            With .Worksheets(1)
                .Range("A" & .Rows.Count).End(xlUp).Offset(1).Value = strString
            End With
        End If
        r = r + 1
    Next i
    .Close True
End With
End Sub

PS Wel even het pad naar het te openen bestand terug aanpassen.

 

[greatmaze]

Thx voor je antwoord, maar het werkt niet.
Ik heb de code een beetje aangepast.
Ik run de macro dus vanuit Word.
In Word heb ik een tabel met maar 1 regel, van die regel wil ik de waarde uit de eerste kolom in een Excel document zetten te beginnen in A1.
Dan ververs ik mijn Word document en wil opnieuw de waarde uit die tabel in hetzelfde Excel document zetten, maar dan op de eerste vrije regel in de A kolom, dus hier wordt dat A2 enz.
Elke keer als ik de waarde heb weggeschreven moet het Excel document gesloten en opgeslagen worden.
Excel bibliotheek stond altijd al aan.
Nu gaat het fout zodra ik bij "wb.Worksheet(1)" aankom, met alleen een "." krijg ik al een foutmelding als ik de macro start.
Dus wat ik nu nog mis is naar de eerste lege cell in A te gaan de waarde wegschrijven en daarna het Excel document afsluiten en opslaan.
Nu had ik dat opslaan ook al, maar het bleek dus dat het rapport wel werd afgesloten, maar niet opgeslagen.
Het probleem is dus dat alles vanuit Word wordt gedaan.

Sub aaOpenExcel()
Dim wb         As Object
Dim xlsApp     As Object
Dim oTable     As Table
Dim curRowValue As String
Dim i          As Long
Dim r          As Long
Dim curRow          As Long
Dim strString  As String

Set oTable = ActiveDocument.Tables(15)
r = 1

'De waarde uit de eerste Cell van de WORDtable wordt gelezen
strString = oTable.Rows.Item(1).Cells(1).Range
'De check of de cell leeg is
If Strings.Len(strString) > 2 Then
    strString = Left(strString, Len(strString) - 1)
    MsgBox (strString)
        
    Set xlsApp = CreateObject("Excel.Application")
    xlsApp.Visible = True
    Set wb = xlsApp.Workbooks.Open("C:\Temp\Test.xlsx")
        
    With wb.worksheet(1)
        curRowValue = wb.Worksheets(1).Range("A" & r).Value
        MsgBox (curRowValue)

        If IsEmpty(curRowValue) Or curRowValue = "" Then
            wb.Worksheets(1).Range("A" & r).Value = strString
        Else
            r = r + 1
        End If
    End With
End If
End Sub

 

[greatmaze]

Hallo allemaal,
Ik heb het probleem opgelost.
Bedankt voor jullie antwoorden, onderstaand de oplossing.

Sub aaOpenExcel()
Dim wb          As Object
Dim ws          As Object
Dim xlsApp      As Object
Dim oTable      As Table
Dim curRowValue As String
Dim i           As Long
Dim r           As Long
Dim curRow      As Long
Dim strString   As String

Set oTable = ActiveDocument.Tables(15)
r = 1

'De waarde uit de eerste Cell van de WORDtable wordt gelezen
strString = oTable.Rows.Item(1).Cells(1).Range
'De check of de cell leeg is
If Strings.Len(strString) > 2 Then
    strString = Left(strString, Len(strString) - 1)
    'MsgBox (strString)
        
    Set xlsApp = CreateObject("Excel.Application")
    xlsApp.Visible = True
    Set wb = xlsApp.Workbooks.Open("C:\Temp\Test.xlsx")
    Set ws = wb.Sheets(1)
    curRowValue = wb.Worksheets(1).Range("A" & r).Value
    
    With ws
    Do While curRowValue <> ""
        curRowValue = wb.Worksheets(1).Range("A" & r).Value
        'MsgBox (curRowValue)
        
        If curRowValue <> "" Then r = r + 1
        End If
    Loop
    wb.Worksheets(1).Range("A" & r).Value = strString
    End With
End If

wb.Close savechanges:=True

xlsApp.Quit

Set oTable = Nothing
Set wb = Nothing
Set xlsApp = Nothing
End Sub

 

[Warme bakkertje]

Als er toch maar 1 waarde in je tabel staat, waarom dan een loop in je 1ste macro ???
Zoiets noemen ze iemand op het verkeerde been zetten

Thx voor je antwoord, maar het werkt niet.

Omdat jij het niet aan de praat krijgt wil dit niet zeggen dat het niet werkt, want dat doet het wel degelijk dus jouw loop om de eerstvolgende lege cel te vinden is dus meer dan overbodig.
Wat die With ws structuur daar staat te doen is mij ook een raadsel, want je doet er niks mee.

Sub aaaOpenExcel()
Dim strString As String
With CreateObject("Excel.Application")
    .Visible = True
    With .Workbooks.Open("G:\Mijn documenten\Map1.xlsm")
        strString = ActiveDocument.Tables(1).Rows.Item(1).Cells(1).Range 'De waarde uit de eerste Cell wordt gelezen
        If Len(strString) > 2 Then 'De check of de cell leeg is
            strString = Left(strString, Len(strString) - 1)
            With .Worksheets(1)
                .Range("A" & .Rows.Count).End(xlUp).Offset(1).Value = strString
            End With
        End If
        .Close True
    End With
    .Quit
End With
End Sub

 

[greatmaze]

Hi Rudi

Je hebt gelijk die WITH is overbodig.
Maar bij mij werkt het niet want ik krijg een foutmelding dat ie "xlUp" niet kent.
Maar dit probleem heb ik afgevangen en nu werkt het precies zoals ik wil dat het moet werken.

Iig bedankt voor je moeite.