Aktiven Sheet in andere bestehende Mappe kopieren

Hola liebes Forum, habe noch eine Frage.
Ich möchte durch einen Button den aktiven Sheet kopieren und dann unter so etwas wie "SPEICHERN UNTER/EINFÜGEN UNTER" in eine andere bestehen Mappe als letzten Sheet einfügen.
Da sich die Mappen immer ändern brauche ich also eine Funktion die mich fragt in welche Mappe EINFÜGEN.
Kann jemand mit meiner Fragestellung was anfangen und ist es machbar?
In Schritten bräuchte ich dieses.
Aktiven Sheet kopieren, Abrage Sheet speichern/einfügen unter, ausgewählte Mappe öffnen, Sheet als letztes Blatt einfügen, Mappe speichern und schliessen und zum Aktiven Sheet zurückgehen. Ich hoffe ich konnte es erklären.
Vielen Dank wie immer schon mal im Voraus
Luna

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

' ********************************************************************** ' Modul: Modul1 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub copySheet() Dim strFile As String Dim objWB As Workbook, objSh As Object Dim bolOpen As Boolean On Error GoTo ErrExit With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlManual .DisplayAlerts = False End With With Application.FileDialog(msoFileDialogFilePicker) .InitialFileName = "D:\" .Title = "Datei auswählen" .ButtonName = "Auswahl..." .InitialView = msoFileDialogViewList .Filters.Clear .Filters.Add "Excel Dateien", "*.xls; *.xlsx; *.xlsm; *.xls*", 1 .Filters.Add "Alle Dateien", "*.*", 2 .FilterIndex = 1 If .Show = -1 Then strFile = .SelectedItems(1) End With If Len(strFile) Then If strFile = ThisWorkbook.FullName Then MsgBox "Einfügen in diese Datei nicht möglich!", vbExclamation Exit Sub End If Set objSh = ActiveSheet For Each objWB In Application.Workbooks If objWB.FullName = strFile Then bolOpen = True Exit For End If Next If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile) objSh.Copy After:=objWB.Sheets(objWB.Sheets.Count) objWB.Save If Not bolOpen Then objWB.Close objSh.Activate End If ErrExit: With Err If .Number <> 0 Then MsgBox "Fehler in Prozedur:" & vbTab & "'copySheet'" & vbLf & String(60, "_") & _ vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _ "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _ .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _ "VBA - Fehler in Prozedur - copySheet" .Clear End If End With On Error GoTo 0 With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlAutomatic .DisplayAlerts = True .StatusBar = False End With Set objWB = Nothing Set objSh = Nothing End Sub

Hallo Luna,
den Code in der kopierten Tabelle löscht dieser Code.

' **********************************************************************
' Modul: Modul2  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copySheet()
Dim strFile As String
Dim objWB As Workbook, objSh As Object
Dim bolOpen As Boolean

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .Calculation = xlManual
  .DisplayAlerts = False
End With

With Application.FileDialog(msoFileDialogFilePicker)
  .InitialFileName = "E:\Forum"
  .Title = "Datei auswählen"
  .ButtonName = "Auswahl..."
  .InitialView = msoFileDialogViewList
  .Filters.Clear
  .Filters.Add "Excel Dateien", "*.xls; *.xlsx; *.xlsm; *.xls*", 1
  .Filters.Add "Alle Dateien", "*.*", 2
  .FilterIndex = 1
  If .Show = -1 Then strFile = .SelectedItems(1)
End With

If Len(strFile) Then
  If strFile = ThisWorkbook.FullName Then
    MsgBox "Einfügen in diese Datei nicht möglich!", vbExclamation
    Exit Sub
  End If
  Set objSh = ActiveSheet
  For Each objWB In Application.Workbooks
    If objWB.FullName = strFile Then
      bolOpen = True
      Exit For
    End If
  Next
  If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile)
  
  With objWB
    objSh.Copy After:=.Sheets(.Sheets.Count)
    With .VBProject.vbComponents(.Sheets(.Sheets.Count).CodeName).CodeModule
      .DeleteLines 1, .CountOfLines
    End With
    .Save
    If Not bolOpen Then .Close
  End With
  objSh.Activate
End If

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'copySheet'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - copySheet"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = xlAutomatic
  .DisplayAlerts = True
  .StatusBar = False
End With

Set objWB = Nothing
Set objSh = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Aktiven Sheet in andere bestehende Mappe kopieren

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Aktiven Sheet in andere bestehende Mappe kopieren

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread