Office-Fragen.de
aktivierte Kontrollkästchen in Worddatei kopieren - Druckversion

+- Office-Fragen.de (https://office-fragen.de)
+-- Forum: Microsoft Office (https://office-fragen.de/forum-1.html)
+--- Forum: Excel (https://office-fragen.de/forum-2.html)
+--- Thema: aktivierte Kontrollkästchen in Worddatei kopieren (/thread-7649.html)

aktivierte Kontrollkästchen in Worddatei kopieren - schotzer - 02.03.2020

Hallo,

ich habe vor einiger Zeit ein VBA Makro geschrieben, dass alle Zellen die mit einer Checkbox versehen waren kopiert haben und in eine Worddatei kopiert haben. Nach der Umstellung auf Excel 2016 funktioniert dieses Makro leider nicht mehr und ich bin ein wenig überfordert wieso.
Die Tabelle ist wie folgt aufgebaut:
In Spalte A sind die Checkboxen und in Spalte B und C der entsprechende Text, der dann bei Aktivierung in das Worddokument kopiert werden soll.

Hier mein Code:

Code:
Sub Makro12()
    Range("A4:A50").AutoFilter Field:=1, Criteria1:=True
    Range("B4:C50").Select
    Cells.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy

    Dim objWord As Object
    Set objWord = CreateObject("Word.Application")

    objWord.documents.Open "T:\SCHWLA\Faxblätter\Briefkopflandesamt.docm"

    objWord.Visible = True

    objWord.ActiveDocument.Bookmarks("Data").Select

    objWord.Selection.PasteSpecial
   
    Dim c_Path As String
    Dim c_Name As String
    Dim strNewName As String, strTemp As String
    Dim bFound As Boolean, iCount As Integer, iMax As Integer
    Dim strName As String

    c_Path = objWord.ActiveDocument.Path & "\"
    c_Name = "Faxblatt"
    bFound = False: iCount = 0

    strNewName = c_Name & "_" & Format(Date, "dd-MM-yyyy")
    strName = Dir(c_Path, vbDirectory)     ' Ersten Eintrag abrufen.
    Do While strName <> ""     ' Schleife beginnen.
    If strName <> "." And strName <> ".." Then
        If InStr(1, strName, strNewName) > 0 And GetAttr(c_Path & strName) <> vbDirectory Then
            iCount = iCount + 1
            strTemp = Mid(strName, Len(strNewName) + 2, InStr(1, strName, ".docm") - Len(strNewName) - 2)
            If iMax < CInt(strTemp) Then iMax = CInt(strTemp)
            Debug.Print strName
        End If
    End If
    strName = Dir     ' Nächsten Eintrag abrufen.
    Loop
    iMax = iMax + 1
    strTemp = String(2 - Len(CStr(iMax)), "0") & CStr(iMax)
    strNewName = strNewName & "-" & strTemp ' & ".docm"
    objWord.ActiveDocument.SaveAs c_Path & strNewName
    MsgBox "Die Datei wurde unter folgendem Namen gespeichert:" & vbCrLf & strNewName
   
    Set objWord = Nothing
    ActiveWindow.SmallScroll Down:=0
   
    Dim chb As CheckBox
    For Each chb In ActiveSheet.CheckBoxes
    chb.Value = False
    Next
    ActiveSheet.Range("$A$1:$C$100").AutoFilter Field:=1
End Sub


Bei Klicken des Buttons, welcher Makro 12 auslöst, wird die entsprechende Worddatei mit der Wordvorlage und dem Namen erstellt. Allerdings werden die Texte nicht mehr eingefügt, sondern nur noch das hier (egal welche Checkboxen aktiv sind):

[Bild: fehler.jpg]
Würde mich über jegliche Hilfe freuen.

Danke
Sascha