PDA

View Full Version : 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/documents/excel/3600-excel-check-if-a-file-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!