AW: Kopieren von Blättern mit Werten
03.07.2018 16:11:01
Blättern
Hallo Bernd,
hier mal das Makro-Grundgerüst.
Falls die zu kopierenden Bereiche varieren, dann müssen Kriterien definiert werden nach denen Excel die Startzelle und die Größe des zu kopierendne Bereichs ermitteln soll.
Gruß
Franz
'Code in einem allgemeinen Modul der Datei
Option Explicit
Sub Export_Daten()
Dim wkbQuelle As Workbook, wksQuelle As Worksheet
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim rngStart As Range, rngCopy As Range, rngUsed As Range
Set wkbQuelle = ActiveWorkbook
For Each wksQuelle In wkbQuelle.Worksheets
Set rngStart = Nothing
With wksQuelle
'Wenn die Starzelle der Daten und die Größe des zu kopierenden Bereich variieren, _
dann mussen Kriterien festgelegt werden mit denen Excel Startzelle und zu _
kopierenden Bereich ermitteln kann
Select Case wksQuelle.Name 'Blattname in Quellblättern prüfen
Case "Vorlage1"
Set rngStart = .Range("A1")
Set rngCopy = rngStart.Resize(11, 4)
Case "Vorlage2"
Set rngStart = .Range("A2")
Set rngCopy = rngStart.Resize(9, 4)
Case "Vorlage3"
Set rngStart = .Range("B3")
Set rngCopy = rngStart.Resize(15, 4)
Case Else
'do nothing
End Select
If Not rngStart Is Nothing Then
If wkbZiel Is Nothing Then
'neue Arbeitsmappe mit einem Tabellenblatt anlegen
Set wkbZiel = Application.Workbooks.Add(Template:=xlWBATWorksheet)
Else
'neues Blatt in Zielmappe anfügen
With wkbZiel
.Worksheets.Add After:=.Worksheets(.Worksheets.Count)
End With
End If
With wkbZiel
'letztes Blatt in Zielmappe als Zieltabelle stzen
Set wksZiel = .Worksheets(.Worksheets.Count)
'Zielblatt umbenennen
wksZiel.Name = wksQuelle.Name
End With
'Spaltenbreiten in Zielmappe gleich Breiten in Quellblatt setzen
Set rngUsed = wksQuelle.UsedRange
rngUsed.Copy
wksZiel.Range(rngUsed.Address).PasteSpecial Paste:=xlPasteColumnWidths
'Quellbereich kopieren und im Ziel Formate und Werte an gleicher Position einfügen
rngCopy.Copy
wksZiel.Range(rngCopy.Address).PasteSpecial Paste:=xlPasteFormats
wksZiel.Range(rngCopy.Address).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range(rngStart.Address).Select
End If
End With
Next
End Sub