11.07.2019, 09:22
Hallo, :19:
wenn es auch bei H3 bis H33 geht, dann brauchst du nicht so viele Textmarken, sondern kannst gleich A3:H33 schreiben und an eine Textmarke setzen. Aber ich kenne die Gegebenheiten bei dir nicht. Prinzipiell so: :21:
Das ist jetzt mit einem neuen Dokument. Diese Anpassung wirst du aber hinbekommen. Hier wird von "Tabelle2" der Bereich "A1:C10" genommen.
wenn es auch bei H3 bis H33 geht, dann brauchst du nicht so viele Textmarken, sondern kannst gleich A3:H33 schreiben und an eine Textmarke setzen. Aber ich kenne die Gegebenheiten bei dir nicht. Prinzipiell so: :21:
Code:
Option Explicit
Public Sub Main()
Dim strBookmark As String
Dim objWDApp As Object
Dim objWDDoc As Object
Set objWDApp = OffApp("Word")
strBookmark = "Wochentag"
If Not objWDApp Is Nothing Then
With objWDApp
Set objWDDoc = .Documents.Add
objWDDoc.Bookmarks.Add Name:=strBookmark
ThisWorkbook.Worksheets("Tabelle2").Range("A1:C10").Copy
objWDDoc.Bookmarks(strBookmark).Range.PasteExcelTable False, False, False
Application.CutCopyMode = False
End With
End If
Fin:
Set objWDDoc = Nothing
Set objWDApp = Nothing
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
objApp.Visible = True
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objApp = Nothing
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objApp = Nothing
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End FunctionDas ist jetzt mit einem neuen Dokument. Diese Anpassung wirst du aber hinbekommen. Hier wird von "Tabelle2" der Bereich "A1:C10" genommen.
