Tabellenblätter nebeneinander kopieren

Gallanz · 2012-11-03T09:39:32+00:00

Hallo, ich möchte 8 bestimmte Tabellenblätter aus einem Excel Dokument in ein neues kopieren (ca 30 Tabellenblätter insgesamt). Dabei soll der Inhalt in ein Tabellenblatt zusammengeführt werden - also nebeneinander. Range aller 8 Blätter: A1:CF550 Die Bezeichnung der 8 Tabellenblätter sollte am besten in Spalte A aufgeführt werden um nicht die Übersicht zu verlieren. Gallanz

Hallo,
Du hast VBA nein angegeben, ob dies ohne VBA geht kann ich mir nicht vorstellen.
Hier mal eine erste Variante.
Der Code kommt in ein Standard Modul.
Starten kannst Du den Code über einen Button den Du diesen Code zuweist.
Den Bereich wo die Tabellen gelistet sind, müsstest Du evtl. noch anpassen.

Sub KopiereTabellen()
Dim rngTabellen As Range, rngLetzte As Range, strRange$
Dim NewWB As Workbook
Dim strFehler$

'Quelle der Tabellen 
Set rngTabellen = Tabelle1.Range("A2:A9")
'zu kopierender Bereich 
strRange = "A1:CF550"

For Each rngTabellen In rngTabellen.Cells
    If CheckTab(rngTabellen.Value) Then
        If NewWB Is Nothing Then Set NewWB = Workbooks.Add(1)
        With NewWB.Worksheets(1)
            Set rngLetzte = .Cells(.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row, 1)
            ThisWorkbook.Sheets(rngTabellen.Value).Range(strRange).Copy rngLetzte
        End With
    Else
        strFehler = strFehler & Chr(7) & rngTabellen.Value & vbCr
    End If
Next rngTabellen

If strFehler <> "" Then
    MsgBox "Tabellen wurden nicht gefunden!" & vbCr & vbCr & Left$(strFehler, Len(strFehler) - 1)
End If
End Sub

Function CheckTab(strTabname$) As Boolean
On Error Resume Next
CheckTab = IsNumeric(ThisWorkbook.Sheets(strTabname).Index)
End Function

Gruß Tino

Sry für meine Unfähigkeit, VBA ist nicht wirklich mein Fachgebiet.
Ich habe aus deiner datei den folgenden Code

Option Explicit
Sub KopiereTabellen()
Dim Tabelle As Worksheet, Tabellen()
Dim rngLetzte As Range, strRange$
Dim NewWB As Workbook
'Tabellen erweitern oder und anpassen
Tabellen = Array("Tabelle1", "Tabelle2", "Tabelle3")
'zu kopierenter Bereich
strRange = "A1:CF550"
For Each Tabelle In ThisWorkbook.Sheets(Tabellen)
If NewWB Is Nothing Then
Set NewWB = Workbooks.Add(1)
End If
With NewWB.Worksheets(1)
If rngLetzte Is Nothing Then
Set rngLetzte = .Cells(2, 1)
Else
Set rngLetzte = .Cells(2, .Columns.Count).End(xlToLeft).Offset(, 2)
End If
rngLetzte.Offset(-1, 0) = Tabelle.Name
Tabelle.Range(strRange).Copy rngLetzte
End With
Next Tabelle
If Not NewWB Is Nothing Then
NewWB.Worksheets(1).UsedRange.entircolumn.AutoFit
End If
End Sub
Function CheckTab(strTabname$) As Boolean
On Error Resume Next
CheckTab = IsNumeric(ThisWorkbook.Sheets(strTabname).Index)
End Function

Option Explicit
Sub Makro1()
' Makro1 Makro
Sheets(Array("Tabelle1", "Tabelle3")).Select
Sheets("Tabelle1").Activate
End Sub

Beim 1. habe ich aus


Tabellen = Array("Tabelle1", "Tabelle2", "Tabelle3")



Tabellen = Array("Tabelle29", "Tabelle31", "Tabelle32", "Tabelle33", "Tabelle34", "Tabelle35", "Tabelle36", "Tabelle37")

gemacht
Was muss beim 2. geändert werden?
Gallanz

Tabellenblätter nebeneinander kopieren

Forumthread: Tabellenblätter nebeneinander kopieren

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Tabellenblätter nebeneinander kopieren

Forumthread: Tabellenblätter nebeneinander kopieren

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread