Office: (Office 2016) Wert in Autoauswahl schreiben

Hallo,

Habe eine Liste mit Teilnehmern, welche für verschiedene Aktionen eingeteilt werden (siehe Beispieldatei).
Die Teilnahme-Kennzeichnung erfolgt im Beispiel in Spalte D mit einem "x" manuell.
Sind die gewünschten Teilnehmer gekennzeichnet, erfolgt der Druck (in Beispieldatei deaktiviert) über das im Beispiel integrierte Makro und anschließend die Umwandlung des "x" in ein "o" sowie die Aufhebung des Autofilters und der Wert in G3 wird eins höher gesetzt.
Jetzt möchte ich eigentlich noch, das in Spalte C bei den jeweils mit x gekennzeichneten Teilnehmern der aktuelle Wert aus G3 eingetragen wird.
Entweder neu eingetragen oder wenn bereits einer vorhanden entsprechend ersetzt.
Wie kann ich das hinbekommen?

Code:

Sub XprintchangetoO()
'
' XprintchangetoO Makro
    
    With ActiveSheet.PageSetup
        .LeftHeader = "&""Arial,Fett""&10&K000000" & Format(Now)
        .CenterHeader = "&""Arial,Fett""&20&K000000" & "Teilnahmeaktion " & Sheets("Teilnahme").Range("G3") + 1
        .RightHeader = "&""Arial,Fett""&16&K000000" & "Kennung:                    "
        
        .LeftFooter = "&""Arial,Fett""&10&K000000" & "Teilnahmenachweis"
        .CenterFooter = "&""Arial,Fett""&9&K000000" & ActiveWorkbook.Name
        .RightFooter = ""
    End With


    ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=4, Criteria1:= _
        "x"
        
        
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
     
    Columns("D:D").Select
    Selection.Replace What:="x", Replacement:="o", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    ActiveSheet.ListObjects("Tabelle1").Range.AutoFilter Field:=4
    Range("G3").Value = Range("G3").Value + 1
    Range("A1").Select
End Sub

Danke für Hilfestellung

Matt

 

Hi Matt,

versuche es mal so:

Code:

Sub XprintchangetoO()
'
' XprintchangetoO Makro
    Dim rngZelle As Range
    With ActiveSheet.PageSetup
        .LeftHeader = "&""Arial,Fett""&10&K000000" & Format(Now)
        .CenterHeader = "&""Arial,Fett""&20&K000000" & "Teilnahmeaktion " & Sheets("Teilnahme").Range("G3") + 1
        .RightHeader = "&""Arial,Fett""&16&K000000" & "Kennung:                    "
        
        .LeftFooter = "&""Arial,Fett""&10&K000000" & "Teilnamenachweis"
        .CenterFooter = "&""Arial,Fett""&9&K000000" & ActiveWorkbook.Name
        .RightFooter = ""
    End With

    With ActiveSheet.ListObjects("Tabelle1")
        .Range.AutoFilter Field:=4, Criteria1:="x"
               
        'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
            IgnorePrintAreas:=False
     
        .DataBodyRange.Columns(4).Replace What:="x", Replacement:="o", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Range.AutoFilter Field:=4
        Range("G3").Value = Range("G3").Value + 1
        For Each rngZelle In .DataBodyRange.Columns(4).SpecialCells(xlCellTypeConstants)
            If rngZelle = "o" Then rngZelle.Offset(0, -1) = Range("G3")
        Next rngZelle
    End With
End Sub

Bis später,
Karin

 

Hallo Karin,

Vielen Dank!
Die Reihenfolge noch etwas verändert und schon war es perfekt!
Super!

Gruß Matt

 

Hi Matt,

dann poste doch bitte deinen geänderten Code, damit alle Forums-User davon profitieren können.

Bis später,
Karin

 

Hallo,

Natürlich gern:

Code:

Sub XprintchangetoO()
'
' XprintchangetoO Makro
    Dim rngZelle As Range
    With ActiveSheet.PageSetup
        .LeftHeader = "&""Arial,Fett""&10&K000000" & Format(Now)
        .CenterHeader = "&""Arial,Fett""&20&K000000" & "Teilnahmeaktion " & Sheets("Teilnahme").Range("G3") + 1
        .RightHeader = "&""Arial,Fett""&16&K000000" & "Kennung:                    "
        
        .LeftFooter = "&""Arial,Fett""&10&K000000" & "Teilnahmenachweis"
        .CenterFooter = "&""Arial,Fett""&9&K000000" & ActiveWorkbook.Name
        .RightFooter = ""
    End With


    With ActiveSheet.ListObjects("Tabelle1")
        .Range.AutoFilter Field:=4, Criteria1:="x"
               
        ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
            IgnorePrintAreas:=False
          
        For Each rngZelle In .DataBodyRange.Columns(4).SpecialCells(xlCellTypeConstants)
            If rngZelle = "x" Then rngZelle.Offset(0, -1) = Range("G3")
        Next rngZelle
        
        .DataBodyRange.Columns(4).Replace What:="x", Replacement:="o", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Range.AutoFilter Field:=4
        Range("G3").Value = Range("G3").Value + 1
    End With
End Sub

So sieht's jetzt aus.
Alle mit "x"-markierten Einträge werden gedruckt, die Aktionsnummer bei denen eingetragen, dann auf "o" gesetzt und zuletzt Aktionszähler eins hoch gezählt.

Danke nochmals

Gruß Matt