Auto Kopieren von mehreren bestehenden Arbeitsblättern bei Eingabe der Anzahl

Dieses Thema Auto Kopieren von mehreren bestehenden Arbeitsblättern bei Eingabe der Anzahl im Forum "Windows XP Forum" wurde erstellt von Gerd1, 12. Sep. 2007.

Thema: Auto Kopieren von mehreren bestehenden Arbeitsblättern bei Eingabe der Anzahl Hallo Ihr Wissenden (und Unwissenden), Ich habe beim Durchsuchen im Forum keine Lösung gefunden, daher möchte ich...

  1. Hallo Ihr Wissenden (und Unwissenden),

    Ich habe beim Durchsuchen im Forum keine Lösung gefunden, daher möchte ich mein Problem hier stellen:

    Ich brauche eine automatisch ablaufende Routine, die nach Eingabe eines Zahlenwertes im 1. Tabellenblatt (z.B. 2 oder 3) weitere, bereits in derselben Arbeitsmappe vorhandene und in der Routine fix festzulegendeTabellenblätter mit all ihren Inhalten zweimal oder dreimal kopiert und ans Ende der Arbeitsmappe stellt (Die Namen der zu kopierenden Arbeitsblätter bleiben also unverändert). Besser wäre noch, wenn die kopierten Blätter unmittelbar hinter die bestehenden gereiht werden.
    Also eine Routine, die z.B. bei Eingabe 2 auf dem 1. Tabellenblatt und Wunsch nach Kopieren des vorhandenen Blattes Bundesland eine Lösung Bundesland/Bundesland(1)/Bundesland(2) herstellt.
    Gibt es so eine Funktion/Routine bzw. weiss jemand von Euch, ob oder wie ich diese herstellen kann ? (Bin noch ziemlicher Laie in den Tiefen von Excel)

    Ich bin für jede Idee oder Unterstützung dankbar. Falls ich eine Beantwortung im Forum übersehen habe, wäre auch ein einfacher Verweis auf diese Beantwortung sehr hilfreich.

    bereits vorweg mit herzlichem Dank an das Forum

    Gerd1, Wien
     
  2. Hallo Gerd1,

    das könnte folgendermaßen aussehen.

    Folgenden Code packst du in ein Modul in deiner Arbeitsmappe.
    Dabei mußst du die als anzupassenden Zeilen entsprechend anpassen.
    Code:
    Option Explicit
    
    'Blattname auf dem die zu überwachende Zelle liegt
    '< < < < < A N P A S S E N > > > > >
    Public Const cBLTNAME_VERW = Verwaltung
    Public Const cBLTNAME_VERW_RANGE_SCHALTER = A2->Bereich für Eingabe Anzahl
    Private Const cMAXANZKOPIEN = 10->max. zulaessige Eingabe
    '**********************************************************************
    Function MeineBlattNamen(v As Variant)
    ->Hier die Blattnamen eintragen, die kopiert werden sollen
     v = Array(Sonne, Mond, Sterne)
    End Function
    '< < < < < A N P A S S E N  E N D E > > > > >
    
    Function EingabeAnzahlBlattKopien()
     Dim ws As Worksheet
     Dim lAnzKopien As Long
     
     On Error Resume Next
     Set ws = ThisWorkbook.Worksheets(cBLTNAME_VERW)
     On Error GoTo 0
     If ws Is Nothing Then
      MsgBox  Blatt-> & cBLTNAME_VERW &-> kann nicht erreicht werden.
     Else
      
     ->Anzahl holen
      On Error Resume Next
      lAnzKopien = ws.Range(cBLTNAME_VERW_RANGE_SCHALTER).Value
      If Err.Number <> 0 Then
       Err.Clear
       MsgBox _
        Eingegebene Anzahl in  & cBLTNAME_VERW_RANGE_SCHALTER & _
         kann nicht interpretiert werden.
      
      Else
      ->kopieren
       If (lAnzKopien > 0) And (lAnzKopien <= cMAXANZKOPIEN) Then
        Application.ScreenUpdating = False
        Call BlaetterKopieren(lAnzKopien)
        Application.ScreenUpdating = True
       End If
      End If
     
     ->Eingabe löschen
      Application.EnableEvents = False
      ws.Range(cBLTNAME_VERW_RANGE_SCHALTER).Value = 
      Application.EnableEvents = True
      
     End If
     
    AUFRAEUMEN:
     Set ws = Nothing
    End Function
    
    
    '**********************************************************************
    Private Function BlaetterKopieren(lAnzKopien As Long)
     
     Dim v As Variant, x As Long
     Dim ws As Worksheet
     
     Call MeineBlattNamenHolenPruefen(v)
      
     For x = LBound(v) To UBound(v)
      Set ws = ThisWorkbook.Worksheets(v(x))
      Call BlattKopieren(ws, lAnzKopien)
     Next
    AUFRAEUMEN:
     Set ws = Nothing
    End Function
      
    '**********************************************************************
    Private Function MeineBlattNamenHolenPruefen(v As Variant)
     Dim x As Long, y As Long, ws As Worksheet
     
     Call MeineBlattNamen(v)
     
    ->Blätter pruefen
     On Error Resume Next
     For x = LBound(v) To UBound(v)
      Set ws = Nothing
      Set ws = ThisWorkbook.Worksheets(v(x))
      If ws Is Nothing Then
       Err.Clear
       MsgBox Blatt-> & v(x) &-> nicht erreichbar
       v(x) = 
      End If
     Next
     On Error GoTo 0
    AUFRAEUMEN:
     Set ws = Nothing
    End Function
    
    '**********************************************************************
    Private Function BlattKopieren(ws As Variant, lAnzKopien As Long)
    
      Dim lIndex As Long, i As Long
      
     ->Position des Blattes feststellen
      lIndex = ws.Index
      
     ->Anzahl Kopien vor Blatt einfügen
      For i = 1 To lAnzKopien
       ws.Select
       ws.Copy Before:=ws
      Next
      
     ->alte Position des Blattes wieder herstellen
      If lIndex = 1 Then
       ws.Move Before:=ws.Parent.Sheets(1)
      Else
       ws.Move After:=ws.Parent.Sheets(lIndex - 1)
      End If
    
    End Function
    So das war der ausführende Teil. Den folgenden Code mußt du in die Code-Seite deiner Arbeitsmappe (DieseArbeitsmappe) kopieren.

    Code:
    Option Explicit
    Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
     Dim Zelle As Range
     If Sh.Name = cBLTNAME_VERW Then
      For Each Zelle In Target
       If Zelle.Address(False, False) = cBLTNAME_VERW_RANGE_SCHALTER Then
        Call EingabeAnzahlBlattKopien
       End If
      Next
     End If
    End Sub
    Gruß Matjes :)
     
  3. Hallo Matjes,

    Herzlichen Dank für die umfassende und detaillierte Lösung. Ich hab's gerade ausprobiert, es funktioniert problemlos und genauso wie ich mir's vorgestellt habe. Ich habe gar nicht damit gerechnet, gleich die ganze Lösung ausprogrammiert zu erhalten - mein ehrliches Komliment.

    mit herzlichen Grüssen aus Wien

    Gerd1
     
Die Seite wird geladen...

Auto Kopieren von mehreren bestehenden Arbeitsblättern bei Eingabe der Anzahl - Ähnliche Themen

Forum Datum
Bilder von Karte automatisch ins Netzwerk kopieren. Womit? Software: Empfehlungen, Gesuche & Problemlösungen 2. Okt. 2016
Programm zum nächtlich automatischen kopieren? Software: Empfehlungen, Gesuche & Problemlösungen 4. Nov. 2009
Excel: Schwierigkeiten beim autom. Kopieren Microsoft Office Suite 8. Aug. 2007
Dateien automatisch im Netz kopieren Windows XP Forum 22. März 2006
automisches Kopieren von Daten Windows XP Forum 12. Jan. 2006