Arbeitsblätter zwischen Mappen verschieben

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Arbeitsblätter zwischen Mappen verschieben
von: Vic
Geschrieben am: 30.07.2015 13:51:11

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 <- läuft ohne Fehler durch, hat aber nicht den gewümschten  _
Effekt
strOrdner = ActiveWorkbook.Path
ChDir strOrdner
Team = [M6]
Set wbQuelle = ThisWorkbook
Set wsQuelle = wbQuelle.ActiveSheet
   
    strOrdner = strOrdner & "\"
    strDateiname = (Team & ".xlsm")
    On Error Resume Next 'Fehlerbehandlung
    Set wbZiel = Workbooks(strDateiname)
    If Sheets("Start").Range("B4") = ActiveSheet.Range("M6") Then
        MsgBox "Der Mitarbeiter ist bereits Mitglied dieser Gruppe"
            Exit Sub
        Else
    If Not wbZiel Is Nothing Then
        ActiveSheet.Move After:=Workbooks(Team & ".xlsm").Sheets("Start")
        Else
'Wenn Mappe noch nicht geöffnet ist
    If Dir(strOrdner & strDateiname) <> "" 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

Bild

Betrifft: AW: Arbeitsblätter zwischen Mappen verschieben
von: fcs
Geschrieben am: 01.08.2015 12:06:10
Hallo Vic,
aus irgendeinem Grund werden die Verweise der Datenprüfungen mit dem Blatt kopiert, obwohl sie entfernt werden. Scheinbar räumt Excel hier erst auf, wenn die Datei gespeichert und geschlossen wird.
Ich hab jetzt mal versucht die Namen der Quell-Mappe nach dem Verschieben des Blattes zu entfernen. Dabei ist mir gelegentlich
On Error Resume Next
zum Verhängnis geworden.
Auch die Reihenfolge der Prüfungen (Datei geöffnet, MA-Blatt schon vorhanden) muss etwas anders sein.
Gruß
Franz

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 '<- läuft ohne Fehler durch, hat aber nicht den gewü _
mschten _
            Effekt
        Application.Calculate
        Application.DisplayAlerts = False
        wsQuelle.Move After:=wbZiel.Sheets("Start")
        Application.DisplayAlerts = True
        For Each objName In wbZiel.Names
            If InStr(1, objName.RefersToLocal, "[" & wbQuelle.Name & "]") > 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


Bild

Betrifft: AW: Arbeitsblätter zwischen Mappen verschieben
von: Vic
Geschrieben am: 03.08.2015 11:18:36
Hallo Franz,
Danke für die Mühen.

aus irgendeinem Grund werden die Verweise der Datenprüfungen mit dem Blatt kopiert,
obwohl sie entfernt werden
Genau das hat mich zum Verzweifeln gebracht. Ich probiere mal deinen Vorschlag und gebe dir eine Rückmeldung. Mit der Prüfung, ob ein MA schon vorhanden ist, hatte ich bisher keinerlei Probleme. Kannst du mir das etwas näher erläutern?
Vic

Bild

Betrifft: AW: Arbeitsblätter zwischen Mappen verschieben
von: Vic
Geschrieben am: 03.08.2015 14:48:37
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

Bild

Betrifft: AW: Arbeitsblätter zwischen Mappen verschieben
von: fcs
Geschrieben am: 03.08.2015 21:55:08
Hallo Vic,
wahrscheinlich ist die ANweisung
On Error Resume Next der Grund.
Ich hab die Prüfung,ob die Zieldatei schon geöffnet ist und die Prüfung of das MA-Blatt in der Zieldatei schon vorhanden ist, geändert.
Es wird jetzt positiv geprüft und nicht einfach bei Fehler weiter gemacht.
In der ZIP-Datei sind zwei Beispieldaeien.
https://www.herber.de/bbs/user/99297.zip
Ich konnte mit dem Makro die MA-Blätter beliebig zwischen den beiden Dateieien hin und her schieben.
Bei den Namen gab es keine Probleme, nur die unerwünscht kopierten Namen werden gelöscht.
Falls bei dir noch in der For-Next-Schleife ein Fehler auftritt, dann muss in der Fehlerprüfung ein Case-Fall mit der entsprechenden Fehlernummer eingefügt werden, der das Makro an der Position NextName fortsetzt.
Grundsätzlich könntest du die Namen in der Workbook_Open-Prozedur auch immer neu festlegen, bevor du die Gültigkeitsprüfungen neu setzt. Siehe nachfolgendes Beispiel.
Gruß
Franz

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


Bild

Betrifft: AW: Arbeitsblätter zwischen Mappen verschieben
von: Vic
Geschrieben am: 04.08.2015 07:30:02
Hallo Franz,
danke erneut. On error resume next habe ich nun schon raus genommen, weil ich in der Einzelschrittprüfung immer wieder gemerkt habe, das es Murks ist. Ich komme heute nicht dazu - werde morgen mal mit deinen Mappen testen.
Vic

Bild

Betrifft: @Franz
von: Vic
Geschrieben am: 06.08.2015 11:49:58
Hallo Franz, habe es nun mit deinem Code hinbekommen - vielen Dank dafür. Zuverlässig funktioniert es, wenn die Bereichsbenennung und Datenprüfung jeweils in der Workbook_open gesetzt werden. Wie du schon gesagt hast, war on error resume next kontraproduktiv. Ein weiteres Hindernis war die Formatierung der Kataloge als Tabelle. Das macht zwar die Katalogpflege einfach, damit werden diese Bezüge aber offensichtlich von Excel anders angelegt und lassen sich nicht richtig entfernen. Die Bezüge werden im Namensmanager auch anders (anderes Symbol) dargestellt. Was sich da genau hinter verbirgt, erschließt sich mir im Augenblick noch nicht.
Nochmals Danke
Vic

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Arbeitsblätter zwischen Mappen verschieben"