Check if Excel list is already open, if so then close Excel list.

**illogic** · 07-11-2017, 10:50 PM

Hello,

i have a word document which automatically transfers data to an excel list when saved.
Therefore it opens the list automatically, transfers the data, saves the excel list and closes it.

Some users sometimes forget to close the excel list when they manually open it.

When the macro is executed while the excel list is allready opened, a second instance (write protected) is opened and the makro fails to save the transfered data.

This is what i have so far:

'Code to check if the excel list is opened.

Sub ExcelMapCheckIfOpen()
    Dim xlApp As Object
    Dim xlWBook As Object
    On Error Resume Next
    Set xlApp = CreateObject("excel.Application")
    Set xlWBook = xlApp.Workbooks(ThisDocument.Path & "\artexGeräteliste.xlsx")
    On Error GoTo 0
    If Not xlWBook Is Nothing Then xlWBook.Close False
End Sub


'Code for the data transfer.

Sub DataTransfer(sID As String)
    Dim xlApp As Object
    Dim xlWBook As Object
    Dim fld As FormField
    Dim nRow As Long
    Dim nCol As Integer
    Dim ws As Object
    Dim lfdNr As Long
    Dim NextID As Long
    Dim nInstall As String
    Dim nTech As String, nEqui As String, nTyp As String, nPTB As String, nSNR As String, nSA As String
    Dim nFDSS As String, nEXGRP As String, nBetriebsdruck As String, nBetriebstemp As String, nEinbaulage As String
    Dim nWRKR As String, nFFA As String, nPMBAR As String, nVMBAR As String, nPVDTNG As String, nVVDTNG As String
    Dim nMWRKST As String, nMedium As String, nHeizung As String, nIsolierung As String, nAccess As String
    Dim nrow1 As Long

    Const xlUp = -4162
    Application.ScreenUpdating = False
 
    Set xlApp = CreateObject("excel.Application")
    Set xlWBook = xlApp.Workbooks.Open(ThisDocument.Path & "\artexGeräteliste.xlsx")
    xlWBook.Application.Visible = True
    xlWBook.Application.Sheets("Tankschutzarmaturen").Select
    Set ws = xlWBook.Sheets("Tankschutzarmaturen")
    If sID = "0" Then
    nRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row + 1
    NextID = xlApp.WorksheetFunction.Max(ws.Range("A:A")) + 1
    ws.Cells(nRow, 1) = NextID
    ActiveDocument.Variables("lfdNr").Value = NextID
    ActiveDocument.Save
    Else
        On Error Resume Next
        nRow = xlApp.WorksheetFunction.Match(CLng(sID), ws.Range("A:A"), 0)
        If nRow = 0 Then nRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row + 1
        On Error GoTo 0
    End If

The code which i use to check if the excel list is already opened doesn't work. The List is not beeing closed before the transfer macro opens another instance.

Does anyone have an idea how i could achieve this?

**gmayor** · 07-12-2017, 01:25 AM

If the 'list' is a worksheet with a header row at row 1 starting in column A then it would be simpler to use ADOBB to write directly to the worksheet without opening it. Then the problem doesn't arise.

The following Word Function will write the values to the next row of the named worksheet.

Private Function WriteToWorksheet(strWorkBook As String, _
                                  strWorksheet As String, _
                                  strValues As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 12 Jul 2017
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkBook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strWorksheet & "$] VALUES('" & strValues & "')"
    Set CN = CreateObject("ADODB.Connection")
    Call CN.Open(ConnectionString)
    Call CN.Execute(strSQL, , 1 Or 128)
    CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

You would call this function from your existing macro that collects the data. As you have only posted part of your macro and I don't therefore know how many fields you have thus values to write, so the following may not match exactly what you have. If you don't have 22 columns with names that match the names I extracted from what you did supply of your macro, then the following would crash, but so you can test the premise I have changed the folder to your Desktop folder, where it will create the workbook if not already present. If present, the data addition is virtually instantaneous.

You should be able to modify the macro to work with your values.

Sub Example()
'Graham Mayor - http://www.gmayor.com - Last updated - 12 Jul 2017 
Dim strValues As String
Dim strWorkBook As String

'I assumed these were your data columns
Dim nTech As String, nEqui As String, nTyp As String, nPTB As String, nSNR As String, nSA As String
Dim nFDSS As String, nEXGRP As String, nBetriebsdruck As String, nBetriebstemp As String, nEinbaulage As String
Dim nWRKR As String, nFFA As String, nPMBAR As String, nVMBAR As String, nPVDTNG As String, nVVDTNG As String
Dim nMWRKST As String, nMedium As String, nHeizung As String, nIsolierung As String, nAccess As String
'''''''''''''''''''
Dim i As Integer
Dim fso As Object
Dim xlApp As Object
Dim xlWB As Object
Dim bXLStarted As Boolean

    'Dummy values
    nTech = "111"
    nEqui = "222"
    nTyp = "333"
    nPTB = "444"
    nSNR = "555"
    nSA = "666"
    nFDSS = "777"
    nEXGRP = "888"
    nBetriebsdruck = "999"
    nBetriebstemp = "111"
    nEinbaulage = "222"
    nWRKR = "333"
    nFFA = "444"
    nPMBAR = "555"
    nVMBAR = "666"
    nPVDTNG = "777"
    nVVDTNG = "888"
    nMWRKST = "999"
    nMedium = "111"
    nHeizung = "222"
    nIsolierung = "333"
    nAccess = "444"

    strWorkBook = Environ("USERPROFILE") & Chr(92) & "Desktop" & "\artexGeräteliste.xlsx"
    strValues = nTech & "', '" & nEqui & "', '" & nTyp & "', '" & _
                nPTB & "', '" & nSNR & "', '" & nSA & "', '" & nFDSS & "', '" & _
                nEXGRP & "', '" & nBetriebsdruck & "', '" & nBetriebstemp & "', '" & _
                nEinbaulage & "', '" & nWRKR & "', '" & nFFA & "', '" & _
                nPMBAR & "', '" & nVMBAR & "', '" & nPVDTNG & "', '" & _
                nVVDTNG & "', '" & nMWRKST & "', '" & nMedium & "', '" & _
                nHeizung & "', '" & nIsolierung & "', '" & nAccess


    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(strWorkBook) Then
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bXLStarted = True
        End If
        On Error GoTo 0
        'Open the workbook to input the data

        Set xlWB = xlApp.Workbooks.Add
        With xlWB.Sheets(1)
            .Range("A1") = "nTech"
            .Range("B1") = "nEqui"
            .Range("C1") = "nTyp"
            .Range("D1") = "nPTB"
            .Range("E1") = "nSNR"
            .Range("F1") = "nSA"
            .Range("G1") = "nFDSS"
            .Range("H1") = "nEXGRP"
            .Range("I1") = "nBetriebsdruck"
            .Range("J1") = "nBetriebstemp"
            .Range("K1") = "nEinbaulage"
            .Range("L1") = "nWRKR"
            .Range("M1") = "nFFA"
            .Range("N1") = "nPMBAR"
            .Range("O1") = "nVMBAR"
            .Range("P1") = "nPVDTNG"
            .Range("Q1") = "nVVDTNG"
            .Range("R1") = "nMWRKST"
            .Range("S1") = "nMedium"
            .Range("T1") = "nHeizung"
            .Range("U1") = "nIsolierung"
            .Range("V1") = "nAccess"

        End With
        xlWB.SaveAs strWorkBook
        xlWB.Close 1
        If bXLStarted Then
            xlApp.Quit
            Set xlApp = Nothing
            Set xlWB = Nothing
        End If
    End If


    WriteToWorksheet strWorkBook:=strWorkBook, strWorksheet:="Sheet1", strValues:=strValues
lbl_Exit:
    Exit Sub
End Sub

**illogic** · 07-12-2017, 03:36 AM

Hello,

thank you very much for your effort!
That looks very promissing. I will have a look at it. Hopefully i am able to make it work for me.

Meanwhile i post the complete code, because i assume i will run into some problems when i try to implement this code into my existing code.
One of the macros generates an ID which is stored in the word document and the excel list as well. This ongoing number is also used to identify if a document has already been saved in order to prevent data from an already saved document to be transfered to the excel list over and over again. That is to prevent duplicate entries.

This is the code from my ms word object "This Document":

'''''Code to automate the calender inside the protocoll
Private Sub Document_Open()
Dim cc As ContentControl

With ActiveDocument
    For Each cc In .ContentControls
        If cc.Tag = "Kalender" Then
            cc.Range.Text = Date
        End If
    Next cc
End With
End Sub

Sub FilePrintDefault()
If Checkfields = True Then
ActiveDocument.PrintOut
End If
End Sub

Sub FilePrint()
FilePrintDefault
End Sub

''''Code that generates the id which is stored inside the protocoll to detect if it has been saved before
Sub FileSave()
Dim oDoc As Document
Dim oVar As Variable
Dim bVar As Boolean
Dim lngID As Long
Dim lngAsk As Long
Dim vbCancel As Boolean, vbNo As Boolean, vbYes As Boolean
Set oDoc = ActiveDocument
If Checkfields = True Then
If oDoc.Path = "" Then
FileSaveAs
End If
If ID_Tester > 0 Then

lngAsk = MsgBox("ACHTUNG!" & vbCr & _
vbCr & _
"Dieses  Protokoll wurde bereits gespeichert und die Daten an Pos. " &  ID_Tester & " in die Geräteliste übertragen!" & vbCr & _
vbCr & _
"Müssen  nachträglich Daten im Protokoll geändert werden, kann der bestehende  Eintrag in der Geräteliste automatisch aktualisiert werden!" & vbCr  & _
vbCr & _
"• Wähle 'Ja' um den Eintrag an Pos. " & ID_Tester & " in der Geräteliste zu aktualisieren." & vbCr & _
"• Wähle 'Nein' um das Protokoll ohne Aktualisierung zu speichern." & vbCr & _
"• Wähle 'Abbrechen' um den Speichervorgang zu beenden.", vbYesNoCancel)
Select Case lngAsk
Case 6
MsgBox ("Der bestehende Eintrag an Pos. " & ID_Tester & " in der Geräteliste wird jetzt aktualisiert!")
lngID = ID_Tester
DataTransfer CStr(lngID)

Case 7
MsgBox ("Dokument wird ohne Aktualisierung der Geräteliste gespeichert!")
oDoc.Save
Exit Sub

Case 2
MsgBox ("Speichervorgang wird abgebrochen!")
Exit Sub
End Select

ElseIf ID_Tester <= 0 Then
lngAsk = MsgBox("ACHTUNG!" & vbCr & _
vbCr & _
"Dieses Protokoll wird zum ersten Mal gespeichert!" & vbCr & _
"Die Daten dieses Protokolls wurden noch nicht in die Geräteliste übertragen!" & vbCr & _
vbCr & _
"• Wähle 'Ja' um die Daten in die Geräteliste zu übertragen." & vbCr & _
"• Wähle 'Nein' um das Protokoll ohne Datenübertragung zu speichern." & vbCr & _
"• Wähle 'Abbrechen' um den Speichervorgang zu beenden.", vbYesNoCancel)
Select Case lngAsk
Case 6
MsgBox ("Neuer Eintrag in der Geräteliste wird erstellt!")
lngID = ID_Tester
DataTransfer CStr(lngID)

Case 7
MsgBox ("Dokument wird ohne Datenübertragung gespeichert!")
oDoc.Save
Exit Sub

Case 2
MsgBox ("Speichervorgang wird abgebrochen!")
Exit Sub
End Select
End If

DataTransfer CStr(lngID)
If Not oDoc.Saved Then oDoc.Save
End If
End Sub

Sub FileSaveAs()
If Checkfields = True Then
    Dialogs(wdDialogFileSaveAs).Show
End If
End Sub
...
...
...' Code shortened / irrelevant for the subject

This is the complete code for the data transfer. stored in a seperate module "Word2Excel":

Sub DataTransfer(sID As String)
    Dim xlApp As Object
    Dim xlWBook As Object
    Dim fld As FormField
    Dim nRow As Long
    Dim nCol As Integer
    Dim ws As Object
    Dim lfdNr As Long
    Dim NextID As Long
    Dim nInstall As String
    Dim nTech As String, nEqui As String, nTyp As String, nPTB As String, nSNR As String, nSA As String
    Dim nFDSS As String, nEXGRP As String, nBetriebsdruck As String, nBetriebstemp As String, nEinbaulage As String
    Dim nWRKR As String, nFFA As String, nPMBAR As String, nVMBAR As String, nPVDTNG As String, nVVDTNG As String
    Dim nMWRKST As String, nMedium As String, nHeizung As String, nIsolierung As String, nAccess As String
    Dim nrow1 As Long

    Const xlUp = -4162
    Application.ScreenUpdating = False

    Set xlApp = CreateObject("excel.Application")
    Set xlWBook = xlApp.Workbooks.Open(ThisDocument.Path & "\artexGeräteliste.xlsx")
    xlWBook.Application.Visible = True
    xlWBook.Application.Sheets("Tankschutzarmaturen").Select
    Set ws = xlWBook.Sheets("Tankschutzarmaturen")
    If sID = "0" Then
    nRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row + 1
    NextID = xlApp.WorksheetFunction.Max(ws.Range("A:A")) + 1
    ws.Cells(nRow, 1) = NextID
    ActiveDocument.Variables("lfdNr").Value = NextID
    ActiveDocument.Save
    Else
        On Error Resume Next
        nRow = xlApp.WorksheetFunction.Match(CLng(sID), ws.Range("A:A"), 0)
        If nRow = 0 Then nRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row + 1
        On Error GoTo 0
    End If

    Cells(nRow, 1).RowHeight = 18

    nInstall = ActiveDocument.FormFields("Gebäude").Result & " - " & ActiveDocument.FormFields("Ebene").Result
    nTech = ActiveDocument.FormFields("ObjNr").Result
    nEqui = ActiveDocument.FormFields("EquiNr").Result
     nTyp = ActiveDocument.FormFields("Typ").Result & "-" &  ActiveDocument.FormFields("TypAdd1").Result & "-" &  ActiveDocument.FormFields("TypAdd2").Result
    nPTB = ActiveDocument.FormFields("PTB").Result
    nSNR = ActiveDocument.FormFields("SNR").Result
    nSA = ActiveDocument.FormFields("SA").Result
    nFDSS = ActiveDocument.FormFields("FDSS").Result
    nEXGRP = ActiveDocument.FormFields("EXGRP").Result
    nBetriebsdruck = ActiveDocument.FormFields("Betriebsdruck").Result
    nBetriebstemp = ActiveDocument.FormFields("Betriebstemp").Result
    nEinbaulage = ActiveDocument.FormFields("Einbaulage").Result
    nWRKR = ActiveDocument.FormFields("WRKR").Result
     nFFA = ActiveDocument.FormFields("FFA").Result & " x " &  ActiveDocument.FormFields("SW").Result & " / " &  ActiveDocument.FormFields("ZWL").Result & " / " &  ActiveDocument.FormFields("WR").Result
    nPMBAR = ActiveDocument.FormFields("PMBAR").Result
    nVMBAR = ActiveDocument.FormFields("VMBAR").Result
    nPVDTNG = ActiveDocument.FormFields("PVDTNG").Result
    nVVDTNG = ActiveDocument.FormFields("VVDTNG").Result
    nMWRKST = ActiveDocument.FormFields("MWRKST").Result
    nMedium = ActiveDocument.FormFields("Medium").Result
    nHeizung = ActiveDocument.FormFields("Heizung").Result
    nIsolierung = ActiveDocument.FormFields("Isolierung").Result
    nAccess = ActiveDocument.FormFields("Access").Result
     xlWBook.Application.Cells(nRow, 2).Value =  ActiveDocument.FormFields("Gebäude").Result & " - " &  ActiveDocument.FormFields("Ebene").Result
    xlWBook.Application.Columns("B:B").EntireColumn.AutoFit
    xlWBook.Application.Cells(nRow, 3).Value = ActiveDocument.FormFields("ObjNr").Result
    xlWBook.Application.Columns("C:C").EntireColumn.AutoFit
    xlWBook.Application.Cells(nRow, 4).Value = ActiveDocument.FormFields("EquiNr").Result
    xlWBook.Application.Cells(nRow, 4).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("D:D").EntireColumn.AutoFit
    If ActiveDocument.FormFields("TypAdd1").Result = "/" Or ActiveDocument.FormFields("TypAdd1").Result = "" Then
     xlWBook.Application.Cells(nRow, 5).Value =  ActiveDocument.FormFields("Typ").Result & "-" &  ActiveDocument.FormFields("TypAdd2").Result
    xlWBook.Application.Cells(nRow, 5).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("E:E").EntireColumn.AutoFit
    Else
     xlWBook.Application.Cells(nRow, 5).Value =  ActiveDocument.FormFields("Typ").Result & "-" &  ActiveDocument.FormFields("TypAdd1").Result & "-" &  ActiveDocument.FormFields("TypAdd2").Result
    xlWBook.Application.Cells(nRow, 5).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("E:E").EntireColumn.AutoFit
    End If
    xlWBook.Application.Cells(nRow, 6).Value = ActiveDocument.FormFields("Betriebsdruck").Result
    xlWBook.Application.Cells(nRow, 6).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 6).NumberFormat = "#,#0.0"
    xlWBook.Application.Cells(nRow, 7).Value = ActiveDocument.FormFields("Betriebstemp").Result
    xlWBook.Application.Cells(nRow, 7).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 7).NumberFormat = "#0"
    xlWBook.Application.Cells(nRow, 8).Value = ActiveDocument.FormFields("PTB").Result
    xlWBook.Application.Cells(nRow, 8).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("H:H").EntireColumn.AutoFit
    xlWBook.Application.Cells(nRow, 10).Value = ActiveDocument.FormFields("SNR").Result
    xlWBook.Application.Cells(nRow, 10).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("J:J").EntireColumn.AutoFit
    If ActiveDocument.FFNEIN.Value = True Then
    xlWBook.Application.Cells(nRow, 9).Value = "-"
    xlWBook.Application.Cells(nRow, 9).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("I:I").EntireColumn.AutoFit
    Else
     xlWBook.Application.Cells(nRow, 9).Value =  ActiveDocument.FormFields("FFA").Result & " x " &  ActiveDocument.FormFields("SW").Result & " / " &  ActiveDocument.FormFields("ZWL").Result & " / " &  ActiveDocument.FormFields("WR").Result
    xlWBook.Application.Cells(nRow, 9).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("I:I").EntireColumn.AutoFit
    End If
    If ActiveDocument.VTNE.Value = True Then
    xlWBook.Application.Cells(nRow, 14).Value = "-"
    xlWBook.Application.Cells(nRow, 14).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 15).Value = "-"
    xlWBook.Application.Cells(nRow, 15).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 16).Value = "-"
    xlWBook.Application.Cells(nRow, 16).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 17).Value = "-"
    xlWBook.Application.Cells(nRow, 17).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 18).Value = "-"
    xlWBook.Application.Cells(nRow, 18).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.VTJA.Value = True Then
    xlWBook.Application.Cells(nRow, 14).Value = ActiveDocument.FormFields("PMBAR").Result
    xlWBook.Application.Cells(nRow, 14).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 15).Value = ActiveDocument.FormFields("VMBAR").Result
    xlWBook.Application.Cells(nRow, 15).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 16).Value = ActiveDocument.FormFields("PVDTNG").Result
    xlWBook.Application.Cells(nRow, 16).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 17).Value = ActiveDocument.FormFields("VVDTNG").Result
    xlWBook.Application.Cells(nRow, 17).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 18).Value = ActiveDocument.FormFields("MWRKST").Result
    xlWBook.Application.Cells(nRow, 18).HorizontalAlignment = xlCenter
    End If
    xlWBook.Application.Cells(nRow, 19).Value = ActiveDocument.FormFields("GDTNG").Result
    xlWBook.Application.Cells(nRow, 19).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("S:S").EntireColumn.AutoFit
    xlWBook.Application.Cells(nRow, 20).Value = ActiveDocument.FormFields("Medium").Result
    xlWBook.Application.Cells(nRow, 20).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("T:T").EntireColumn.AutoFit

    If ActiveDocument.FormFields("Status").Result = "Armatur funktionssicher instandgesetzt. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "OK"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(34, 139, 34)
        xlWBook.Application.Cells(nRow, 12).Interior.ColorIndex = xlNone
    End If

    If ActiveDocument.FormFields("Status").Result = "Neugeräteinstallation durchgeführt. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "OK"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(34, 139, 34)
        xlWBook.Application.Cells(nRow, 12).Interior.ColorIndex = xlNone
    End If

    If ActiveDocument.FormFields("Status").Result = "Weitere Maßnahmen erforderlich. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "Beanstandet"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 255, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("Status").Result = "Fehlendes Bauteil - Zulassung erloschen (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "Beanstandet"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("Status").Result = "Altarmatur - Zulassung zurückgezogen. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "Altarmatur"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("Status").Result = "Altarmatur - Zulassung eingeschränkt. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "Altarmatur"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("Status").Result = "Armatur baulich verändert - Zulassung erloschen. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "Beanstandet"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("Status").Result = "Wartung nicht möglich. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "ohne Wartung"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("Status").Result = "Armatur irreparabel beschädigt. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "Beanstandet"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("Status").Result = "Ohne Typenschild - Armatur nicht identifizierbar. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "Beanstandet"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 0, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("Status").Result = "Armatur nicht verifiziert. (siehe Text)" Then
        xlWBook.Application.Cells(nRow, 12).Value = "Beanstandet"
        xlWBook.Application.Cells(nRow, 12).HorizontalAlignment = xlCenter
        xlWBook.Application.Cells(nRow, 12).Interior.Color = RGB(255, 255, 0)
        xlWBook.Application.Cells(nRow, 12).Font.Bold = True
        xlWBook.Application.Cells(nRow, 12).Font.Color = RGB(0, 0, 0)
    End If

    If ActiveDocument.FormFields("WZKL").Result = "24 Monate" Then
        xlWBook.Application.Cells(nRow, 22).Value = "24"
        xlWBook.Application.Cells(nRow, 22).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("WZKL").Result = "12 Monate" Then
        xlWBook.Application.Cells(nRow, 22).Value = "12"
        xlWBook.Application.Cells(nRow, 22).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("WZKL").Result = "6 Monate" Then
        xlWBook.Application.Cells(nRow, 22).Value = "6"
        xlWBook.Application.Cells(nRow, 22).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("WZKL").Result = "3 Monate" Then
        xlWBook.Application.Cells(nRow, 22).Value = "3"
        xlWBook.Application.Cells(nRow, 22).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("WZKL").Result = "1 Monat" Then
        xlWBook.Application.Cells(nRow, 22).Value = "1"
        xlWBook.Application.Cells(nRow, 22).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("WZKL").Result = "3 Wochen" Then
        xlWBook.Application.Cells(nRow, 22).Value = "0,75"
        xlWBook.Application.Cells(nRow, 22).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("WZKL").Result = "2 Wochen" Then
        xlWBook.Application.Cells(nRow, 22).Value = "0,5"
        xlWBook.Application.Cells(nRow, 22).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("WZKL").Result = "1 Woche" Then
        xlWBook.Application.Cells(nRow, 22).Value = "0,25"
        xlWBook.Application.Cells(nRow, 22).HorizontalAlignment = xlCenter
    End If

    With xlWBook.Application.Cells(nRow, 11)
        .Value = Date
        .NumberFormat = "MM""/""YYYY"
    End With


    xlWBook.Application.Cells(nRow, 13).FormulaR1C1 = _
        "=IF(OR(RC[-2]="""",RC[8]=""""),"""",EDATE(RC[-2],RC[8]))"


    xlWBook.Application.Cells(nRow, 24).Value = ActiveDocument.FormFields("SA").Result
    xlWBook.Application.Cells(nRow, 24).HorizontalAlignment = xlCenter
    xlWBook.Application.Columns("X:X").EntireColumn.AutoFit
    xlWBook.Application.Cells(nRow, 25).Value = ActiveDocument.FormFields("EXGRP").Result
    xlWBook.Application.Cells(nRow, 25).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 26).Value = ActiveDocument.FormFields("FDSS").Result
    xlWBook.Application.Cells(nRow, 26).HorizontalAlignment = xlCenter
    If ActiveDocument.FormFields("WRKR").Result = "Flammensicherung unidirektional" Then
    xlWBook.Application.Cells(nRow, 27).Value = "unidirektional"
    xlWBook.Application.Cells(nRow, 27).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("WRKR").Result = "Flammensicherung bidirektional" Then
    xlWBook.Application.Cells(nRow, 27).Value = "bidirektional"
    xlWBook.Application.Cells(nRow, 27).HorizontalAlignment = xlCenter
    Else
    xlWBook.Application.Cells(nRow, 27).Value = ActiveDocument.FormFields("WRKR").Result
    xlWBook.Application.Cells(nRow, 27).HorizontalAlignment = xlCenter
    End If

    xlWBook.Application.Cells(nRow, 28).Value = ActiveDocument.FormFields("Einbaulage").Result
    xlWBook.Application.Cells(nRow, 28).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 30).Value = ActiveDocument.FormFields("Heizung").Result
    xlWBook.Application.Cells(nRow, 30).HorizontalAlignment = xlCenter
    xlWBook.Application.Cells(nRow, 31).Value = ActiveDocument.FormFields("Isolierung").Result
    xlWBook.Application.Cells(nRow, 31).HorizontalAlignment = xlCenter

    If ActiveDocument.FormFields("Access").Result = "Treppe" Then
    xlWBook.Application.Cells(nRow, 32).Value = "frei"
    xlWBook.Application.Cells(nRow, 32).HorizontalAlignment = xlCenter
    ElseIf ActiveDocument.FormFields("Access").Result = "Steigleiter" Then
    xlWBook.Application.Cells(nRow, 32).Value = "frei"
    xlWBook.Application.Cells(nRow, 32).HorizontalAlignment = xlCenter
    Else
    xlWBook.Application.Cells(nRow, 32).Value = ActiveDocument.FormFields("Access").Result
    xlWBook.Application.Cells(nRow, 32).HorizontalAlignment = xlCenter
    End If

nrow1 = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row - nRow
    If nrow1 > 0 Then
    Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 2).Resize(nrow1).EntireRow.Delete
    End If
Application.ScreenUpdating = True
xlWBook.Close SaveChanges:=True
Application.Quit SaveChanges:=True

End Sub

As you can see, there are many if/else statements etc. that alter cells inside the excel list according to the data source inside the word document.
My Code is pretty messy because it is a grown structure that evolved over time and i never had the time to rewrite everything in order to clean it up properly.
I am not sure if i can make your code work with all that chaos that makes up my code. But i will try.
Maybe you could give me some feedback if in general it would be possible to do.

By the way, the worksheet that receives the data from the word document ist filled starting at row 4 and at column A. The 3 rows above are static and not filled with data.

**gmayor** · 07-12-2017, 04:24 AM

It is difficult enough to do in English

There is no reason why it cannot be adapted to your documents, and while I don't see how your ID tester works (more missing code) or how the IDs themselves work, this is not insurmountable.

You have more than the 22 columns I guessed at so you would have to allow for that and ensure they are in the correct order.

Take a copy of your workbook (and then you don't have to create one to test) and put it somewhere suitable e.g. on the desktop for testing and match the path in the code to that location.

The important bit is

    nTech = ActiveDocument.FormFields("ObjNr").Result 
    nEqui = ActiveDocument.FormFields("EquiNr").Result 'etc 

    nTyp = "333" 
    nPTB = "444" 
    nSNR = "555" 
    nSA = "666" 
    nFDSS = "777" 
    nEXGRP = "888" 
    nBetriebsdruck = "999" 
    nBetriebstemp = "111" 
    nEinbaulage = "222" 
    nWRKR = "333" 
    nFFA = "444" 
    nPMBAR = "555" 
    nVMBAR = "666" 
    nPVDTNG = "777" 
    nVVDTNG = "888" 
    nMWRKST = "999" 
    nMedium = "111" 
    nHeizung = "222" 
    nIsolierung = "333" 
    nAccess = "444" 
     
    strWorkBook = Environ("USERPROFILE") & Chr(92) & "Desktop" & "\artexGeräteliste.xlsx" 

    'Ensure the following values match the list above in the order that the columns are filled
    strValues = nTech & "', '" & nEqui & "', '" & nTyp & "', '" & _ 
    nPTB & "', '" & nSNR & "', '" & nSA & "', '" & nFDSS & "', '" & _ 
    nEXGRP & "', '" & nBetriebsdruck & "', '" & nBetriebstemp & "', '" & _ 
    nEinbaulage & "', '" & nWRKR & "', '" & nFFA & "', '" & _ 
    nPMBAR & "', '" & nVMBAR & "', '" & nPVDTNG & "', '" & _ 
    nVVDTNG & "', '" & nMWRKST & "', '" & nMedium & "', '" & _ 
    nHeizung & "', '" & nIsolierung & "', '" & nAccess

In the meantime you can see https://www.extendoffice.com/documen...e-is-open.html

**illogic** · 07-12-2017, 07:24 AM

Ok, i will try that! This is going to take a while.
Thanks for helping me out!

Thread: Check if Excel list is already open, if so then close Excel list.

Thread Tools

Display

Check if Excel list is already open, if so then close Excel list.

Posting Permissions