Bei Kopieren der Tabelle auch Ausgabeverknüpfung für Checkboxen mitkopieren

Question

Hallo!

Ich habe in Excel 97 einen Fragebogen erstellt. Zu jeder Frage gibt es eine Bewertungsmatrix, das sind jeweils 5 Checkboxen (Formularcheckboxen)

Ich habe den Checkboxen in dem gleichen Tabellenblatt eine Ausgabeverknüpfung zugewiesen (mit wahr und falsch)

Wenn ich jetzt das ganze Tabellenblatt samt Checkboxen kopiere (in der selben Mappe) dann behalten die Checkboxen der Kopie die alte Ausgabevernüpfung bei. (Das heißt, wenn ich in der Kopie ein Häkchen mache wird der Wert der Originaltabelle überschrieben)

Hat jemand eine Lösung für mein Problem parat? (habe schon stundenlang gegoogelt aber hab nichts passendes gefunden) Ich kann die Mappe leider nicht hochladen, weil ich bei der Arbeit bin.

Ich bin mir sicher es gibt eine Lösung

Answer 1

Hi Inka,

ich habe jetzt kein Excel97 da und kann es deshalb nicht testen, aber du kannst es mal mit folgendem Makro probieren:

Sub Ersetzen()
Dim cbbElement As CheckBox
For Each cbbElement In ActiveSheet.CheckBoxes
cbbElement.LinkedCell = Application.Substitute(cbbElement.LinkedCell, "Tabelle1!", "")
Next cbbElement
End Sub

Du musst nur Tabelle1 durch den Tabellennamen ersetzen, auf den sich die Zellverknüpfung in den kopierten Kontrollkästchen bezieht. Beim Ausführen muss natürlich das kopierte Tabellenblatt aktiv sein.

Bis später,
Karin

Answer 2

Danke,

das funktioniert schon mal genau so, wie ich es wollte.

Jetzt noch eine Kleinigkeit:

Wie muss ich den Code ändern, wenn ich automatisch mit dem Kopieren den Code ausführen will, damit ich nicht immer erst den Code einfügen und ausführen muss nachdem ich die Tabelle kopiert habe.

Vielen lieben Dank schonmal, ich finde es klasse, wie schnell man hier Hilfe bekommt, dann ist der Arbeitstag wenigstens nicht mit endlosem Grübeln und Ausprobieren verschenkt.

LG

Answer 3

Hi Inka,

das Kopieren von Tabellen löst leider kein Ereignis aus, mit welchem man die Ausführung des Makros verknüpfen könnte. Du musst es also jedes mal von Hand starten, sobald du das Tabellenblatt kopiert hast. Die einzige Möglichkeit wäre, dass du das Makro in der Personl.xls ablegst und einer Tastenkombination zuweist. In diesem Fall müsstet du das Makro etwas umschreiben, weil es ja durchaus sein kann, dass es nicht immer Tabelle1 ist, die du kopierst:

Sub Ersetzen()
Dim cbbElement As CheckBox
For Each cbbElement In ActiveSheet.CheckBoxes
If InStr(cbbElement.LinkedCell, "!") > 0 Then _
cbbElement.LinkedCell = Mid(cbbElement.LinkedCell, InStr(cbbElement.LinkedCell, "!") + 1)
Next cbbElement
End Sub

Bis später,
Karin

Answer 4

Hallo Karin,

ich hab noch ein bischen gebastelt udn habe jetzt einen Button auf mein Originalformular gelegt. Dazu kopiere ich den Fragebogen auch noch in eine extra Datei, damit ich den neu erzeugten Fragebogen per mail versenden kann. Das ist bestimmt nicht perfekt, aber es funktioniert so wie ich möchte. Vielen dank für deine Mühe.

Hier der Code, falls jemand mal ein ähnliches Problem hat:

Sub Fragebogen_kopieren_BeiKlick()

Dim tabname As String
'Checkbox für neuen Tabellennamen aufrufen

tabname = InputBox("bitte ID für neuen Fragebogen eingeben", "ID")

'Fragebogen kopieren und als neuen Namen den Namen aus der InputBox verwenden

Sheets("Fragebogen").Select
Sheets("Fragebogen").Copy After:=Sheets(Sheets.Count)
Sheets("Fragebogen (2)").Select
Sheets("Fragebogen (2)").Name = tabname

'Ausgabeverknüpfungen in der Kopie anpassen

Dim cbbElement As CheckBox
For Each cbbElement In ActiveSheet.CheckBoxes
cbbElement.LinkedCell = Application.Substitute(cbbElement.LinkedCell, "Fragebogen!", "")
Next cbbElement

'Button in der Kopie löschen
Dim sh As Shape

For Each sh In ActiveSheet.Shapes
If TypeName(sh.OLEFormat.Object) = "Button" Then sh.Delete
Next

'Fragebogen als neue Datei speichern

Dim Dateiname$, Dateipfad

Dateiname = tabname


ActiveSheet.Select
ActiveSheet.Copy

If Dateiname = "" Then Exit Sub

ChDrive "S"
ChDir "S:\Zentral\Organisation\Daten\QM_Z41\Kundenbefragung 2011\Fragebögen fürs Versenden"
Dateipfad = Application.GetSaveAsFilename(Dateiname, FileFilter:="Excel Files (*.xls), *.xls")
If Dateipfad <> False Then
MsgBox "Der Fragebogen wurde gespeichert unter: " & Dateipfad
ActiveWorkbook.SaveAs FileName:=Dateipfad


End If


End Sub

Answer 5

Hi Inka,

du kannst deinen Code noch etwas vereinfachen, da man in VBA zu 99% auf Select und Activate verzichten kann:

Sub Fragebogen_kopieren_BeiKlick()
Dim cbbElement As CheckBox
Dim sh As Shape
Dim tabname As String
Dim Dateipfad As String
'Checkbox für neuen Tabellennamen aufrufen

tabname = InputBox("bitte ID für neuen Fragebogen eingeben", "ID")
If tabname <> "" Then

'Fragebogen kopieren und als neuen Namen den Namen aus der InputBox verwenden
Sheets("Fragebogen").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = tabname

'Ausgabeverknüpfungen in der Kopie anpassen
For Each cbbElement In ActiveSheet.CheckBoxes
cbbElement.LinkedCell = Application.Substitute(cbbElement.LinkedCell, "Fragebogen!", "")
Next cbbElement

'Button in der Kopie löschen
For Each sh In ActiveSheet.Shapes
If TypeName(sh.OLEFormat.Object) = "Button" Then sh.Delete
Next

'Fragebogen als neue Datei speichern
Sheets(tabname).Copy
ChDrive "S"
ChDir "S:\Zentral\Organisation\Daten\QM_Z41\Kundenbefragung 2011\Fragebögen fürs Versenden"
Dateipfad = Application.GetSaveAsFilename(tabname, FileFilter:="Excel Files (*.xls), *.xls")
If Dateipfad <> False Then
ActiveWorkbook.SaveAs Filename:=Dateipfad
MsgBox "Der Fragebogen wurde gespeichert unter: " & Dateipfad
End If
End If
End Sub

Bis später,
Karin