Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Tabellenblätter nebeneinander kopieren

Betrifft: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 09:39:32

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

  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Hajo_Zi
Geschrieben am: 03.11.2012 10:11:26

derv erste Bereich soll als in A31:Cf..., der zweite bereiuch in CG31:...
Erster Tabellename in A1
zweiter Tabellename in A2
habe ich das richtig verstanden?

GrußformelHomepage


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 10:28:00

Die zu kopierenden Zellen sind: A1:CF550

So soll das aussehen:

A1:Name von Tabellenblatt 1
A2:CF551 die kopierten Daten Tabellenblatt 1

CH1: Name von Tabellenblatt 2
CH2:FH551 (müsste FH sein, wenn ich mich nicht verzählt habe) die kopierten Daten von Tabellenblatt 2

usw


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Hajo_Zi
Geschrieben am: 03.11.2012 10:30:44

Also soll der Tabnellenname nicht immer in Spalte A?
Hast Du mal das Makro vopn Tino getestet?

Gruß Hajo


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 11:02:44

Hast recht, soll immer in Zeile 1, ab Zeile 2 dann die Daten.

Gallanz


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Tino
Geschrieben am: 03.11.2012 10:13:17

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


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 11:01:58

Hallo Tino,

leider bekomme ich die Fehlermeldung: "Tabellen nicht gefunden"

Btw, Tabellennamen sollen nicht in Spalte A sondern in Zeile 1 gelistet werden, sonst macht das natürlich auch keinen Sinn.


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Tino
Geschrieben am: 03.11.2012 11:06:49

Hallo,
pass doch den Bereich an (bei Quelle der Tabellen) wo diese bei dir stehen.

Gruß Tino


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 11:32:09

Hie mal ein einfaches Beispiel wie es aussehen soll

https://www.herber.de/bbs/user/82462.xlsx

Die ersten 3 Tabellenblätter sind die Ausgangsdaten.
Das Tabellenblatt "Die erstellte Arbeitsmappe" soll in einer neuen Excel Datei erstellt werden


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Tino
Geschrieben am: 03.11.2012 12:04:29

Hallo,
versuch es mal so.
Datei muss als xlsm gespeichert werden, xlsx kann kein VBA.

https://www.herber.de/bbs/user/82463.xlsm

Gruß Tino


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Matze,Matthias
Geschrieben am: 03.11.2012 12:12:34

Hi ,
kleiner Tippfehler bei:

dies: NewWB.Worksheets(1).UsedRange.entirColumn.AutoFit
ersetzen: NewWB.Worksheets(1).UsedRange.EntireColumn.AutoFit

Matze
Ps der Button kopiert sich mit ??


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 12:22:02

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


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Matze,Matthias
Geschrieben am: 03.11.2012 12:55:21

Hallo,
das Modul kannst du löschen, rechte mastaste auf das Modul/entfernen
wenn Abfrage kommt mit Nein bestätigen
Matze


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 13:06:35

Bekomme folgende Fehlermeldung:
Index außerhalb des gültigen Bereichs (Fehler 9)


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Matze,Matthias
Geschrieben am: 03.11.2012 14:44:29

Poste deinen Code, wir wissen NICHT was du da alles änderst.
Matze


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 15:10:25

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("Tabelle29", "Tabelle31", "Tabelle32", "Tabelle33", "Tabelle34", "Tabelle35" _
, "Tabelle36", "Tabelle37")
   '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



  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Matze,Matthias
Geschrieben am: 03.11.2012 15:16:44

Ha du liest nur die Hälfte der Beiträge die man dir schreibt:

ich hatte darrauf hingewiesen das in diesen Code ein Tippfehler ist:

ersetze: NewWB.Worksheets(1).UsedRange.entircolumn.AutoFit
durch : NewWB.Worksheets(1).UsedRange.Entirecolumn.AutoFit


Und mach mal wegen besser Lesbarkeit nach den End Sub eine Leerzeile

Matze


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Tino
Geschrieben am: 03.11.2012 15:59:31

Hallo,
habe den Code auf Deine Tabellen angepasst.

https://www.herber.de/bbs/user/82464.xlsm


Gruß Tino


  

Betrifft: AW: Tabellenblätter nebeneinander kopieren von: Gallanz
Geschrieben am: 03.11.2012 17:12:16

Cool, danke!


 

Beiträge aus den Excel-Beispielen zum Thema "Tabellenblätter nebeneinander kopieren"