CODEWITHSUNDEEP
vbaexcel
ndslr
ndslr

Reputation: 47

Implement Excel Data into existing Word Document with VBA

i currently have the problem that everytime im trying to open a word document via vba/excel im getting an Application/Object Error. My Idea is that im trying to compare data from two tables and deleting the bad results. After that i want to insert the whole table to the existing word document what im selecting from the selection/opening window.

My Code

    Private Sub CommandButton1_Click()

Dim varDatei As Variant
Dim wordDatei As Variant
Dim objExcel As New Excel.Application
Dim objSheet As Object
Dim wordDoc As Object
Dim extBereich As Variant
Dim intBereich As Variant

Dim appWord As Object

Set intBereich = ThisWorkbook.Sheets(1).Range("A4:A11")

Dim loopStr As Variant
Dim loopStr2 As Variant
Dim found() As Variant
Dim loopInt As Integer
Dim endStr As Variant

Dim extBereich2 As Variant

loopInt = 1
varDatei = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx")

If varDatei <> False Then
    objExcel.Workbooks.Open varDatei
    Set objSheets = objExcel.Sheets(1)
    objSheets.Activate
    LetzteZeile = objSheets.Cells(objSheets.Rows.Count, 3).End(xlUp).Row
    Set extBereich = objSheets.Range("B3:B" & LetzteZeile)

    ReDim found(1 To LetzteZeile)
    For Each loopStr In extBereich
        objSheets.Range("F" & loopStr.Row) = "Good"
        objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 4
        For Each loopStr2 In intBereich
            If (StrComp(loopStr, loopStr2, vbBinaryCompare) = 0) = True Then
                found(loopInt) = objSheets.Range("A" & loopStr.Row)
                loopInt = loopInt + 1
                objSheets.Cells(loopStr.Row, 6) = "Bad"
                objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 3
                Exit For
            End If
        Next loopStr2
    Next loopStr
    loopStr = ""
    If (loopInt <> 1) Then
        endStr = "This is bad:" & vbLf
        For Each loopStr In found
        If (Trim(loopStr & vbNullString) <> vbNullString) Then
            endStr = endStr & loopStr & vbLf
        End If
        Next loopStr
        MsgBox (endStr)
    Else
        MsgBox ("Everythings good")
    End If
    Set appWord = CreateObject("Word.Application")
    appWord.DisplayAlerts = False
    Debug.Print ("123")
    Set wordDoc = appWord.Documents.Open(Application.GetOpenFilename("Word-Dateien (*.doc;*.docx;),*.doc;*.docx"))
    wordDoc.Activate
    Debug.Print ("456")
    loopStr = ""
    For Each loopStr In extBereich
        If (objSheets.Cells(loopStr.Row, 6).Interior.ColorIndex = 3) Then
            objSheets.Range("A" & loopStr.Row & ":" & "E" & loopStr.Row).Delete
        End If
    Next loopStr
    objSheets.Range(Columns(2), Columns(4)).Delete
    objSheets.Range("A3:B" & LetzteZeile).Copy
    appWord.Documents(1).Range.Paste
    With appWord.Documents(1).Tables(1)
        .Columns.AutoFit
    End With
    appWord.PrintOut
    objExcel.Quit
    appWord.Quit
    Set appWord = Nothing
    Set objExcel = Nothing
    Debug.Print loopInt


Else
    MsgBox "Error"
End If

End Sub

Maybe someone of you knew whats the problem?

Error Code is 1004 - Application- or object Error

With best regards and thanks for answering

Upvotes: 1

Views: 149

Answers (1)

EamonnT
EamonnT

Reputation: 56

Your problem is with the line:

objSheets.Range(Columns(2), Columns(4)).Delete

You need to specify where the columns are, e.g.

objSheets.Range(objSheets.Columns(2), objSheets.Columns(4)).Delete

Upvotes: 1

Related Questions