@Matjes - Aktives Tabellenblatt kopieren.

Dieses Thema @Matjes - Aktives Tabellenblatt kopieren. im Forum "Microsoft Office Suite" wurde erstellt von nok106, 10. Feb. 2007.

Thema: @Matjes - Aktives Tabellenblatt kopieren. Hallo Matjes, ich benötige wieder einmal deine Hilfe. Folgendes: Jetzt kopiert das untenstehende Makro ein neues...

  1. Hallo Matjes,

    ich benötige wieder einmal deine Hilfe.

    Folgendes:

    Jetzt kopiert das untenstehende Makro ein neues Tabellenblatt mit lfd. Tabellennummer.

    Ist es möglich den Code so zuändern, dass der Wert von Tabelle1 Zelle (C17), als Blattname erscheint ?

    Hat du eine Idee ob das geht und wenn ja - Wie ?

    Einstweilen herzlichen Dank für dein bemühen.

    MfG Odje



    Code:
    Sub AktivesBlatt_kopieren()
    Rem Der selektierte Bereich eines ArbeitsBlattes wird kopiert
    Rem Zieladresse ist A1
    Rem Das Seitenlayout wird übernommen
    Rem Zeilenhöhe und Spaltenbreite werden übernommen
      
      Dim wb As Workbook, ws As Worksheet, ws2 As Worksheet, r As Range
      Dim x As Long, z As Long, sp As Long
      
      Application.ScreenUpdating = False
      
      Rem Druckbereich auslesen.
      Dim Zeilen As Double
      Dim Spalten As Integer
       For i = 1 To 65536
       s = Cells(i, 256).End(xlToLeft).Column
       If Spalten < s Then
       Spalten = s
       End If
       Next i
       For i = 1 To 256
       z = Cells(65536, i).End(xlUp).Row
       If Zeilen < z Then
       Zeilen = z
       End If
       Next i
       Range(Cells(1, 1), Cells(Zeilen, Spalten)).Select
       Druckbereich = Selection.Address
    
      Set wb = ActiveWorkbook
      Set ws = ActiveSheet
      Set r = Selection
         
      Rem neues Blatt anlegen
      Set ws2 = wb.Worksheets.Add(After:=ws)
      
      Rem Seitenlayout übernehmen
      With ws.PageSetup
        ws2.PageSetup.BottomMargin = .BottomMargin
        ws2.PageSetup.FooterMargin = .FooterMargin
        ws2.PageSetup.HeaderMargin = .HeaderMargin
        ws2.PageSetup.LeftMargin = .LeftMargin
        ws2.PageSetup.Orientation = .Orientation
        ws2.PageSetup.PaperSize = .PaperSize
        ws2.PageSetup.RightMargin = .RightMargin
        ws2.PageSetup.TopMargin = .TopMargin
      End With
    
      Rem selektierten Bereich auf neues Blatt A1 kopieren
      r.Copy ws2.Range(A1)
      
      Rem Zeilehöhen übertragen
      z = 0
      For x = r.Row To r.Row + r.Rows.Count - 1
        z = z + 1
        ws2.Rows(z).RowHeight = ws.Rows(x).RowHeight
      Next
      
     ->Spaltenbreiten übertragen
      sp = 0
      For x = r.Column To r.Column + r.Columns.Count - 1
        sp = sp + 1
        ws2.Columns(sp).ColumnWidth = ws.Columns(x).ColumnWidth
      Next
    
    AUFRAEUMEN:
      Set wb = Nothing: Set ws = Nothing: Set ws2 = Nothing: Set r = Nothing
    Application.ScreenUpdating = True
    End Sub
     
  2. Hallo Odje,

    so könntest du es machen.

    Gruß Matjes :)
    Code:
    Option Explicit
    
    Sub AktivesBlatt_kopieren()
    Rem Der selektierte Bereich eines ArbeitsBlattes wird kopiert
    Rem Zieladresse ist A1
    Rem Das Seitenlayout wird übernommen
    Rem Zeilenhöhe und Spaltenbreite werden übernommen
      
      Dim wb As Workbook, ws As Worksheet, ws2 As Worksheet, r As Range
      Dim i As Long, s As Long, sp As Long, x As Long, z As Long
      Dim Zeilen As Long, Spalten As Long
      Dim sBlattname As String
      
      Application.ScreenUpdating = False
      
      Set wb = ActiveWorkbook
      Set ws = ActiveSheet
      Set r = Selection
      
      For i = 1 To 256
        z = ws.Cells(65536, i).End(xlUp).Row
        If Zeilen < z Then Zeilen = z
      Next i
      
      For i = 1 To 65536
        s = ws.Cells(i, 256).End(xlToLeft).Column
        If Spalten < s Then Spalten = s
      Next i
      
      Set ws2 = wb.Worksheets.Add(After:=ws)->neues Blatt anlegen
      Rem Seitenlayout übernehmen
      With ws.PageSetup
        ws2.PageSetup.BottomMargin = .BottomMargin
        ws2.PageSetup.FooterMargin = .FooterMargin
        ws2.PageSetup.HeaderMargin = .HeaderMargin
        ws2.PageSetup.LeftMargin = .LeftMargin
        ws2.PageSetup.Orientation = .Orientation
        ws2.PageSetup.PaperSize = .PaperSize
        ws2.PageSetup.RightMargin = .RightMargin
        ws2.PageSetup.TopMargin = .TopMargin
      End With
      
      Rem selektierten Bereich auf neues Blatt A1 kopieren
      r.Copy ws2.Range(A1)
      
      Rem Zeilehöhen übertragen
      z = 0
      For x = r.Row To r.Row + r.Rows.Count - 1
        z = z + 1
        ws2.Rows(z).RowHeight = ws.Rows(x).RowHeight
      Next
      
     ->Spaltenbreiten übertragen
      sp = 0
      For x = r.Column To r.Column + r.Columns.Count - 1
        sp = sp + 1
        ws2.Columns(sp).ColumnWidth = ws.Columns(x).ColumnWidth
      Next
      
     ->Blattnamen aus Tabelle1 Zelle (C17)
      sBlattname = wb.Worksheets(Tabelle1).Range(C17).Value
     ->auf neuem Tabellenblatt setzen
      On Error Resume Next
      ws2.Name = sBlattname
      If Err.Number <> 0 Then
        MsgBox _
          Tabellenblatt konnte nicht nach Tabelle1 Range C17 benannte werden. & vbLf & _
          Grund:  & Err.Description & vbLf & _
          Inhalt:->  & sBlattname & ->
        Err.Clear
      End If
      On Error GoTo 0
    
    AUFRAEUMEN:
      Set wb = Nothing: Set ws = Nothing: Set ws2 = Nothing: Set r = Nothing
      Application.ScreenUpdating = True
    End Sub
     
  3. Hallo Matjes,

    alles paletti.

    noch eine Frage:

    Kann man den Code noch so abändern, dass die Kopien auch immer hinten angelegt werden ?

    Tabelle1 ist das Eingabeblatt, wo die Änderungen vorgenommen werden !

    Gruß Odje
     
  4. Also um das neue Blatt als letztes anzufügen müßtest Du
    Code:
      Set ws2 = wb.Worksheets.Add(After:=ws) 
    in
    Code:
      Set ws2 = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)) 
    ändern.

    Gruß Matjes :)
     
  5. Hallo Matjes !

    Danke, klappt wunderbar. :D

    Gruß Odje
     
  6. Hallo Matjes,

    noch eine Frage:

    Kann man den Code noch so abändern wenn die xte  Kopie angelegt wurde, dass ein automatischer Rücksprung

    zum Eingabeblatt statt findet ?   ;)


    Gruß Odje
     
  7. Hallo nok106,

    meinst du so ;)

    Gru0 Matjes :)
    Code:
    Option Explicit
    
    Public lXteKopie As Long
    Private Const cRUECKSPRUNG_NACH_XTER_KOPIE As Long = 3
    Private Const cBLTNAME_EINGABEBLATT As String = Tabelle1
    Private Const cRANGE_BLTNAME As String = C17
    
    Sub AktivesBlatt_kopieren()
    Rem Der selektierte Bereich eines ArbeitsBlattes wird kopiert
    Rem Zieladresse ist A1
    Rem Das Seitenlayout wird übernommen
    Rem Zeilenhöhe und Spaltenbreite werden übernommen
     
     Dim wb As Workbook, ws As Worksheet, ws2 As Worksheet, r As Range
     Dim i As Long, s As Long, sp As Long, x As Long, z As Long
     Dim Zeilen As Long, Spalten As Long
     Dim sBlattname As String
     
     Application.ScreenUpdating = False
     
     Set wb = ActiveWorkbook
     Set ws = ActiveSheet
     Set r = Selection
     
     For i = 1 To 256
      z = ws.Cells(65536, i).End(xlUp).Row
      If Zeilen < z Then Zeilen = z
     Next i
     
     For i = 1 To 65536
      s = ws.Cells(i, 256).End(xlToLeft).Column
      If Spalten < s Then Spalten = s
     Next i
     
    ->neues Blatt anlegen
     Set ws2 = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
     Rem Seitenlayout übernehmen
     With ws.PageSetup
      ws2.PageSetup.BottomMargin = .BottomMargin
      ws2.PageSetup.FooterMargin = .FooterMargin
      ws2.PageSetup.HeaderMargin = .HeaderMargin
      ws2.PageSetup.LeftMargin = .LeftMargin
      ws2.PageSetup.Orientation = .Orientation
      ws2.PageSetup.PaperSize = .PaperSize
      ws2.PageSetup.RightMargin = .RightMargin
      ws2.PageSetup.TopMargin = .TopMargin
     End With
     
     Rem selektierten Bereich auf neues Blatt A1 kopieren
     r.Copy ws2.Range(A1)
     
     Rem Zeilehöhen übertragen
     z = 0
     For x = r.Row To r.Row + r.Rows.Count - 1
      z = z + 1
      ws2.Rows(z).RowHeight = ws.Rows(x).RowHeight
     Next
     
    ->Spaltenbreiten übertragen
     sp = 0
     For x = r.Column To r.Column + r.Columns.Count - 1
      sp = sp + 1
      ws2.Columns(sp).ColumnWidth = ws.Columns(x).ColumnWidth
     Next
     
    ->Blattnamen aus Tabelle1 Zelle (C17)
     sBlattname = wb.Worksheets(cBLTNAME_EINGABEBLATT).Range(cRANGE_BLTNAME).Value
    ->auf neuem Tabellenblatt setzen
     On Error Resume Next
     ws2.Name = sBlattname
     If Err.Number <> 0 Then
      MsgBox _
       Tabellenblatt konnte nicht nach  & _
       cBLTNAME_EINGABEBLATT & _
        Range  & _
       cRANGE_BLTNAME & _
        benannte werden. & vbLf & _
       Grund:  & Err.Description & vbLf & _
       Inhalt:->  & sBlattname & ->
      Err.Clear
     End If
     On Error GoTo 0
     
    ->cBLTNAME_EINGABEBLATT nach xtem Aufruf aktivieren
     lXteKopie = lXteKopie + 1
     If lXteKopie >= cRUECKSPRUNG_NACH_XTER_KOPIE Then
      lXteKopie = 0
      wb.Worksheets(cBLTNAME_EINGABEBLATT).Activate
     End If
     
    AUFRAEUMEN:
     Set wb = Nothing: Set ws = Nothing: Set ws2 = Nothing: Set r = Nothing
     Application.ScreenUpdating = True
    End Sub
     
  8. Hallo Matjes,

    meine Frage wurde etwas blöd gestellt !

    Ich meinte mit der xten Kopie die letzte Kopie ....!!!!!!!!

    Habe das Makro mal durchlaufen lassen, es bleibt bei der letzten Kopie stehen und macht nicht den Rücksprung

    zur Eingabetabelle.  :'(

    Gruß Odje
     
  9. Setzt du
    Code:
    Private Const cRUECKSPRUNG_NACH_XTER_KOPIE As Long = 3
    auf 1, also
    Code:
    Private Const cRUECKSPRUNG_NACH_XTER_KOPIE As Long = 1
    , dann wird nach jeder Kopie zum Eingabeblatt zurückgesprungen.

    In diesem Fall kann dann
    Code:
     ->cBLTNAME_EINGABEBLATT nach xtem Aufruf aktivieren
      lXteKopie = lXteKopie + 1
      If lXteKopie >= cRUECKSPRUNG_NACH_XTER_KOPIE Then
        lXteKopie = 0
        wb.Worksheets(cBLTNAME_EINGABEBLATT).Activate
      End If
    durch
    Code:
      wb.Worksheets(cBLTNAME_EINGABEBLATT).Activate
    ersetzt werden.

    Gruß Matjes :)
     
  10. Hallo Matjes !

    Danke, klappt wie geschmiert.

    Wünsche noch einen schönen Tag.

    MfG Odje
     
Die Seite wird geladen...

@Matjes - Aktives Tabellenblatt kopieren. - Ähnliche Themen

Forum Datum
Zum Wechseln in ein anderes aktives Fenster muss ich über die Taskleiste gehen Windows 8 Forum 13. Nov. 2014
Maus springt in neues aktives Fenster Windows 7 Forum 11. Sep. 2011
Interaktives Trainig Windows XP Forum 20. Feb. 2007
Microsoft Interaktives Training - Fehlermeldung Windows XP Forum 9. Sep. 2006
Aktives Desktop Objekt entfernen Windows XP Forum 22. Apr. 2005