Fehler in VBA
21.07.2003 11:03:57
Wolfgang
ich versuche mit einem Wordmakro Daten in ein Excelsheet zu übertragen. Der Vorgang funktioniert beim ersten Mal ganz toll. auch weitere Übertragungen der Daten sind erfolgreich, solange ich das Workbook, in das ich schreibe nicht schließe. Wird das Workbook von Word jedoch ein weiteres Mal geöffnet, da es in Excel bereits geschlossen wurde, dann wird mein Eintrag in die erste Zeile geschrieben, und nicht in die letzte Zeile, in der noch kein Eintrag steht.
Kann mir bitte jemand helfen.
Danke
Wolfgang
Hier meinen Code:
strPath = ActiveDocument.Path
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
strFileName = "Quality_check.xls"
PathName = strPath & strFileName
On Error Resume Next
Err.Clear
Set xl = GetObject(, "Excel.Application")
If Err.Number > 0 Then
Set xl = CreateObject("Excel.Application")
Set wb = xl.Workbooks.Open(PathName)
Else
On Error Resume Next
Err.Clear
xl.Workbooks(strFileName).Activate
If Err.Number > 0 Then
Set wb = xl.Workbooks.Open(PathName)
End If
End If
xl.Visible = True
'Zeilen werden gezählt, in denen ein Eintrag steht.
'Nächster Eintrag wird nach dem letzten Eintrag angefügt
LastRow = xl.Cells(Rows.Count, 4).End(xlUp).Row
'MsgBox "Zeilen: " & LastRow
actualRow = LastRow + 1
xl.Cells(actualRow, 1).EntireRow.Insert
xl.Cells(actualRow, 2) = dnamevalue
xl.Cells(actualRow, 3) = productvalue
xl.Cells(actualRow, 4) = deldatevalue
xl.Cells(actualRow, 5) = percent & "%"
If avA1 = False Then
If avB1 = False Then
xl.Cells(actualRow, 6) = resC1
Else
xl.Cells(actualRow, 6) = resB1
End If
Else
xl.Cells(actualRow, 6) = resA1
End If
If avA = False Then
If avB = False Then
xl.Cells(actualRow, 7) = ergC
Else
xl.Cells(actualRow, 7) = ergB
End If
Else
xl.Cells(actualRow, 7) = ergA
End If
xl.Cells(actualRow, 8).FormulaR1C1 = "=AVERAGE(IF(RC[-2]>0.66,1+1.5*(RC[-2]-1),0),IF(RC[-1]>0.66,1+1.5*(RC[-1]-1),0))"
xl.Cells(actualRow, 9).FormulaR1C1 = "=IF(RC[-4]="""","""",RC[-4]*RC[-1])"
xl.Cells(actualRow + 3, 9).FormulaLocal = "=Sum(I7:I" & actualRow & ")"
Set wb = Nothing
Set xl = Nothing
End Sub