@Matjes - Aktives Tabellenblatt kopieren.

  • #1
N

nok106

Bekanntes Mitglied
Themenersteller
Dabei seit
10.09.2005
Beiträge
108
Reaktionspunkte
0
Ort
Brunsbüttel
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
 
Thema:

@Matjes - Aktives Tabellenblatt kopieren.

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.840
Beiträge
707.963
Mitglieder
51.494
Neuestes Mitglied
Flensburg45
Oben