Arbeitsblätter zwischen Mappen verschieben

Hallo liebe Excelianer,
Ich verzweifle an folgendem Problem:
Ich habe mehrere identisch aufgebaute Team-Arbeitsmappen mit 3 festen Blättern (Kataloge, Blanko-Vorlage und "Startseite")und x Blättern, die jeweils einen Mitarbeiter beinhalten. Die Mitarbeiter haben in einigen Zellbereichen eine Datenprüfung, die sich auf Listen im Kataloge-Blatt bezieht. Die Datenüberprüfung wird per VBA im Worbook open für alle Mitarbeiterblätter gesetzt.
Nun kann ich mit folgendem Code einen Mitarbeiter zu einem anderen Team (in eine andere Mappe) _ verschieben:


Option Explicit
Sub MA_verschieben()
Dim strOrdner As String, strDateiname As String
Dim wbZiel As Workbook
Dim wbQuelle As Workbook
Dim wsQuelle As Worksheet
Dim Team As String
Call Datenüberprüfung_loeschen  "" Then
'Mappe aus o.g. Ordner öffnen :
Set wbZiel = Workbooks.Open(strOrdner & strDateiname, UpdateLinks:=False)
wsQuelle.Activate
ActiveSheet.Move After:=Workbooks(Team & ".xlsm").Sheets("Start")
Else
MsgBox "Folgende Datei existiert nicht : " & vbLf & vbLf & _
strOrdner & strDateiname, vbOKOnly + vbCritical, "Datei nicht gefunden !"
End If
End If
End If
wbZiel.Close SaveChanges:=True
'Speicher für Objektvariable freigeben :
Set wbZiel = Nothing
Set wbQuelle = Nothing
Set wsQuelle = Nothing
End Sub

Leider gelingt es mir ums Verrecken nicht, die Datenprüfung vorher zu entfernen, so dass der Bezug zum alten Team/zur Quellmappe bestehen bleibt und ich den alten Bezug über den Namensmanager manuell immer wieder entfernen muss.
Die restlichen Formatierungen müssen erhalten bleiben.
Ich versuche es bisher so:


Sub Datenüberprüfung_loeschen()
Blattschutz_aus
With Range("M6,C12,C13,C14").Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Blattschutz_ein
End Sub

Einzeln aufgerufen funktioniert es. In Kombination mit dem "Sub MA_verschieben()" aber nicht. Hat jemand eine Idee dazu?
Vielen Dank vorab
Vic

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub MA_verschieben() Dim strOrdner As String, strDateiname As String Dim wbZiel As Workbook Dim wsZiel As Object Dim wbQuelle As Workbook Dim wsQuelle As Worksheet Dim objName As Name Dim Team As String Dim bolZielOpen As Boolean strOrdner = ActiveWorkbook.Path ChDir strOrdner Team = ActiveSheet.Range("M6") Set wbQuelle = ThisWorkbook Set wsQuelle = wbQuelle.ActiveSheet strOrdner = strOrdner & "\" strDateiname = (Team & ".xlsm") On Error Resume Next 'Fehlerbehandlung bolZielOpen = True Set wbZiel = Workbooks(strDateiname) If wbZiel Is Nothing Then 'Wenn Mappe noch nicht geöffnet ist If Dir(strOrdner & strDateiname) "" Then 'Mappe aus o.g. Ordner öffnen : Application.EnableEvents = False Set wbZiel = Workbooks.Open(strOrdner & strDateiname, UpdateLinks:=False) bolZielOpen = False Application.EnableEvents = True Else MsgBox "Folgende Datei existiert nicht : " & vbLf & vbLf & _ strOrdner & strDateiname, vbOKOnly + vbCritical, "Datei nicht gefunden !" GoTo Beenden End If End If 'Prüfen,ob MA-Blatt schon in Ziel-Team vorhanden Set wsZiel = wbZiel.Sheets(wsQuelle.Name) If Not wsZiel Is Nothing Then MsgBox "Der Mitarbeiter ist bereits Mitglied dieser Gruppe" GoTo Beenden Else wsQuelle.Activate Call Datenüberprüfung_loeschen ' 0 Then objName.Delete End If Next End If If bolZielOpen = False Then wbZiel.Close SaveChanges:=True 'Else wbZiel.Save Beenden: 'Speicher für Objektvariable freigeben : Set wbZiel = Nothing Set wbQuelle = Nothing Set wsQuelle = Nothing End Sub Sub Datenüberprüfung_loeschen() Blattschutz_aus With ActiveSheet.Range("M6,C12,C13,C14").Validation .Delete End With Blattschutz_ein End Sub

Hallo Franz / Hallo Excel-Gemeinde
mit

Set wbZiel = Workbooks(strDateiname)

wird die Zielmappe nicht korrekt ermittelt. So:

Set wbZiel = Workbooks(strOrdner & strDateiname)

erfolgt die korrekte Auswahl.
Das Löschen der Namen funktioniert sehr gut - hilft aber in diesem Falle nicht weiter, weil damit alle Namen in der Zielmappe eliminiert werden. Damit ist meine Mappe unbrauchbar, weil die Auswertung aller Blätter auf der Startseite ins Leere läuft. Allerdings überlege ich, auch die Bereiche per VBA im workbook open neu zu setzen. Kann mir jemand sagen, ob so etwas funktioniert? Ich bräuchte für jedes Arbeitsblatt die selben Bereiche. Lässt sich das über eine Schleife realisieren?
Vic

Sub prcMakeNames() ' ggf. gelöschte Namen wieder herstellen ' prcMakeNames Makro Dim arrNames, objName As Name, intName As Integer 'Array mit Namen, die ggf.wieder erstellt werden sollen arrNames = Array("Teams", "Auswahl_C12", "Auswahl_C13", "Auswahl_C14") For intName = LBound(arrNames) To UBound(arrNames) 'Prüfen, ob Name voranden ist For Each objName In ThisWorkbook.Names If objName.Name = arrNames(intName) Then Exit For End If Next If objName Is Nothing Then 'Nicht vorhandenen Namen wieder herstellen Select Case arrNames(intName) Case "Teams" ThisWorkbook.Names.Add Name:=arrNames(intName), _ RefersToR1C1:="=Kataloge!R2C1:R9C1" Case "Auswahl_C12" ThisWorkbook.Names.Add Name:=arrNames(intName), _ RefersToR1C1:="=Kataloge!R2C3:R9C3" Case "Auswahl_C13" ThisWorkbook.Names.Add Name:=arrNames(intName), _ RefersToR1C1:="=Kataloge!R2C5:R9C5" Case "Auswahl_C14" ThisWorkbook.Names.Add Name:=arrNames(intName), _ RefersToR1C1:="=Kataloge!R2C7:R9C7" End Select End If Next End Sub

Beliebteste Forumthreads (12 Monate)

Arbeitsblätter zwischen Mappen verschieben

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread