Woran liegt es bei diesem Code das mir die zuletzt eingegebene zeile nicht mit übertragen wird. In Zeile 1 ist leer, Zeile 2 und 3 sind überschriften der rest ab zeile 4 wird jeweils eingetragen. Das ganze nützt auch nichts wenn ich die datei speichere und neu öffne. Immer die letze zeile wird nicht eingetragen egal wieviele es sind. Weiss jemand Rat?
Private Sub test_Click()
Dim WordObj As Object
Dim Bereich As Variant
Dim WordDoc As Object
Dim ExTab As Object
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim arrWks()
Dim iCounter As Integer, iCount As Integer
For iCounter = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(iCounter) Then
Worksheets(ListBox1.List(iCounter)).Activate
End If
Next iCounter
i = ActiveSheet.UsedRange.Rows.Count
Bereich = Range("A2:F" & i).Value
On Error Resume Next
Set WordObj = GetObject(, "word.application.9")
If Err.Number = 429 Then
Set WordObj = CreateObject("word.application.9")
Err.Number = 0
End If
WordObj.Visible = True
Set WordDoc = WordObj.Documents.Add
Set ExTab = WordDoc.Tables.Add _
(WordObj.Selection.Range, UBound(Bereich, 1), UBound(Bereich, 2))
With ExTab
For x = 1 To UBound(Bereich, 1)
For y = 1 To UBound(Bereich, 2)
.Cell(x, y).Range.InsertAfter Bereich(x, y)
Next y
Next x
End With
Set WordObj = Nothing
Set WordDoc = Nothing
Set ExTab = Nothing
Worksheets("Hilfsblatt").Activate
End Sub
Vielen Dank
Gruss Roger