Tabellenblätter kopieren

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Frank,
nur als Anregung:

Option Explicit
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>'
'                                                                         '
'  es sollen eine Anzahl Tabellenblätter in ein anderes zusammenkopiert   '
'  werden, deren Zeilen bei 10 beginnen und deren Zeilenanzahl beliebig   '
'  sein kann.                                                             '
'  Der Name des empfangenden Blattes wurde mit "Kopie" gewählt, auch da   '
'  soll der erste Eintrag in Zeile 10 beginnen, die anderen BlattInhalte  '
'  sollen nahtlos anschließen.                                            '
'                                                                         '
'  Es wird zuerst geprüft, ob das Tabellenblatt "Kopie" vorhanden ist.    '
'  Ist es nicht vorhanden, dann wird es angelegt.                         '
'  Ist es vorhanden, wird sein Inhalt ab Zeile 10 gelöscht.               '
'                                                                         '
'  Im Array "TB_Verz" werden die Namen der zu kopierenden Tabellenblätter '
'  hinterlegt, in Anführungszeichen, mit Komma getrennt.                  '
'                                                                         '
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>'
'
Sub Kopieren()
Dim WkSh_Ziel  As Object      ' Ziel-Tabellenblatt
Dim bVorhand   As Boolean     ' Schalter 'vorhanden' False/True
Dim iBlatt     As Integer     ' For/Next Index der Tab-Blätter
Dim lZeile     As Long        ' Anzahl Zeilen im Tab-Blatt
Dim TB_Verz    As Variant     ' Array der zu kopierenden Tab-Blätter
Dim sMeldg     As String      ' vbOKCancel - Auswertunh
   Application.ScreenUpdating = False ' Bildschirm-Update unterdrücken
   On Error GoTo Fehler  ' bei Fehler, den Fehler analysieren
'    die Namen der zu kopierenden Tabellenblätter
   TB_Verz = Array("Gustav", "Hugo", "Hans", "Kathrin", "Enzo", _
                   "Knut", "James")
'    prüfen, ob das Tabellenblatt "Kopie" vorhanden ist
   For Each WkSh_Ziel In ThisWorkbook.Sheets
      If WkSh_Ziel.Name = "Kopie" Then
         bVorhand = True  ' JA, das Blatt "Kopie" gibt es.
         Exit For         ' For/Next Schleife verlassen
      End If
   Next
'    wenn vorhanden, den alten Inhalt ab Zeile 10 löschen
'    wenn nicht vorhanden, das Tab-Blatt "Kopie" neu anlegen
   If bVorhand = False Then ' kein Blatt "Kopie" gefunden ?
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = "Kopie"
      Set WkSh_Ziel = Worksheets("Kopie")
    Else
      Set WkSh_Ziel = Worksheets("Kopie")
      WkSh_Ziel.Range("A10").CurrentRegion.ClearContents
   End If
'    auf den Zeilen-Anfang setzen
   lZeile = 10  ' ab Zeile 10 geht's los
'    die Blätter gemäß des Arrays "Arr" kopieren
   For iBlatt = 0 To UBound(TB_Verz) ' über alle angegebenen Tab-Blätter
      Worksheets(TB_Verz(iBlatt)).Range("A10").CurrentRegion.Copy _
         WkSh_Ziel.Cells(lZeile, 1)
      lZeile = WkSh_Ziel.Cells(Rows.Count, 1).End(xlUp).Row + 1
NaechstesBlatt:    ' Ansprung-Marke, wenn fehlerhafter Tab-Blattname
   Next iBlatt
   WkSh_Ziel.Cells.EntireColumn.AutoFit ' Spalten optimal breit machen
   Application.ScreenUpdating = True    ' Bildschirm-Update zulassen
   Exit Sub  ' die normale Verarbeitung ist hier zu Ende.
Fehler:
   If Err.Number = "9" Then ' Tab-Blatt nicht gefunden ?
      sMeldg = MsgBox("Kann es sein, dass Sie einen falschen Tabellenblatt-Namen " & _
                      "angegeben haben?" & Chr(10) & Chr(10) & _
                      "Das Tabellenblatt  """ & TB_Verz(iBlatt) & _
                      """  scheint es nicht zu geben.", _
                      vbOKCancel + vbCritical, _
                      "    falsches, falsch geschriebenes Tabellenblatt?")
      If sMeldg = "1" Then   ' OK wurde angeklickt
         GoTo NaechstesBlatt ' dann nächstes Tab-Blatt kopieren
       Else                  ' sonst
         Exit Sub            ' Abbrechen wurde angeklickt
      End If
   End If
End Sub

Gruß Peter

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread