Blätter in andere Arbeitsmappe kopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Bild

Betrifft: Blätter in andere Arbeitsmappe kopieren
von: Judith
Geschrieben am: 28.07.2015 21:40:12

Hallo zusammen,
ich hoffe mal wieder auf eure Hilfe. Ich habe mehrere Input-Dateien, die von unterschiedlichen Nutzern verwendet werden. Jede Input-Datei soll ein Makro enthalten, dass alle Arbeitsblätter (außer den letzten 4) in eine Summary Datei kopiert. Mit dem folgenden Makro klappt das auch, aber nur wenn die Summary-Datei zu ist. Ist die Datei bereits offen, erhalte ich die Fehlermeldung:"Run-time error 2147221080 (0800401a8)' Automation error. Im Code wird die folgende Zeile als Überltäter markiert:
.Copy After:=Sheets(Sheets.Count)

https://www.herber.de/bbs/user/99136.xlsm
Habt ihr eine Idee wie ich das vermeiden kann oder wie ich den Code ansonsten umschreiben könnte?
Vielen Dank im Voraus für eure Hilfe!
Judith

Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Sepp
Geschrieben am: 28.07.2015 22:16:16
Hallo Judith,

Sub Save_budget_in_summary()
Dim ws As Worksheet, wscnt As Long, cnt As Long, objWB As Workbook
Const Folder = "\\vwoahess100\common\fin\FINPLAN\PR64\Group Functions\" 'Path where summary file is located
Const Wkbk = "Group_Functions_Summary.xlsm" 'Name of Summary workbook

Application.ScreenUpdating = False

wscnt = Worksheets.Count
cnt = 0

'Open summary file to which sheets need to be copied to
On Error GoTo OpenFailed 'If workbook cannot be opened, windows gives an error message. To avoid VBA displaying run-time error as well, jump in code to OpenFailed.
Set objWB = Workbooks.Open(Folder & Wkbk)
On Error GoTo 0 'Stops existing debugger OpenFailed -> if another error occurs, VBA will give error message

If Not objWB Is Nothing Then
  Application.DisplayAlerts = False 'suppress Excel alerts / confirmation prompt
  For Each ws In ThisWorkbook.Sheets
    With ws
      If .Index < wscnt - 3 Then 'Input file has 4 input_tabs (if sheet index is smaller than 1 (which means no budget sheets), then do nothing
        On Error Resume Next 'If sheet already exists in summary sheet, then resume next => delete it
        objWB.Sheets(.Name).Delete
        On Error GoTo 0 'Disable debugger - next time error occurs, error will not be ignored
        
        .Copy After:=objWB.Sheets(objWB.Sheets.Count) 'Copy the sheets at the end of the workbook
        cnt = cnt + 1
      End If
    End With
    Application.DisplayAlerts = True 'Allow Excel to display alerts again
  Next
  
  objWB.Close (True) 'summary workbook will be closed and saved
  MsgBox cnt & " sheets copied to " & Wkbk 'Messagebox how man sheets were copied to summary sheet
  Exit Sub
End If
OpenFailed: 'No instructions if error occurs => nothing will be done from VBA => Additional VBA error message will not be displayed
End Sub


Gruß Sepp


Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Judith
Geschrieben am: 28.07.2015 22:29:36
Hallo Sepp,
leider klappt es nicht ganz wie gedacht. Trotz "Application.DisplayAlerts = False" erfolgt die Nachricht, dass das löschen der Arbeitsblätter bestätigt werden muss.Hier muss ich dann entsprechend der Anzahl der Arbeitsblätter bestätigen.
Ich hätte auch noch dazu sagen müssen, dass es mein Ziel ist, dass wenn ein Arbeitsblatt mit dem gleichen Namen bereits in der Summary Arbeitsmappe existiert, dieses mit dem neuen Arbeitsblatt überschrieben werden soll.
Hast du noch eine Idee?
Viele Grüße
Judith

Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Sepp
Geschrieben am: 28.07.2015 22:47:33
Hallo Judith,
probier mal so.

Sub Save_budget_in_summary()
Dim ws As Worksheet, wscnt As Long, cnt As Long, objWB As Workbook, bolOpen As Boolean
Const Folder = "\\vwoahess100\common\fin\FINPLAN\PR64\Group Functions\" 'Path where summary file is located
Const Wkbk = "Group_Functions_Summary.xlsm" 'Name of Summary workbook

On Error GoTo ErrExit

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

wscnt = Worksheets.Count

For Each objWB In Application.Workbooks
  If objWB.FullName Like "*" & Folder & Wkbk Then
    bolOpen = True
    Exit For
  End If
Next

If Not bolOpen Then Set objWB = Workbooks.Open(Folder & Wkbk)

If Not objWB Is Nothing Then
  For Each ws In ThisWorkbook.Worksheets
    With ws
      If .Index < wscnt - 3 Then 'Input file has 4 input_tabs (if sheet index is smaller than 1 (which means no budget sheets), then do nothing
        If SheetExist(CStr(.Name), objWB) Then objWB.Sheets(.Name).Delete
        .Copy After:=objWB.Sheets(objWB.Sheets.Count) 'Copy the sheets at the end of the workbook
        cnt = cnt + 1
      End If
    End With
  Next
  objWB.Close (True) 'summary workbook will be closed and saved
  MsgBox cnt & " sheets copied to " & Wkbk 'Messagebox how man sheets were copied to summary sheet
End If

ErrExit: 'No instructions if error occurs => nothing will be done from VBA => Additional VBA error message will not be displayed

On Error GoTo 0

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

Set objWB = Nothing
End Sub


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
  If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function


Gruß Sepp


Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Judith
Geschrieben am: 28.07.2015 22:55:38
Hallo Sepp,
wenn die Summary Datei zu ist, funktioniert es einwandfrei. Ist die Datei aber bereits offen, dann passiert nichts :( Hast du eine Ahnung woran es liegen könnte, dass das Makro nichts macht, wenn die Datei bereits offen ist?
Vielen Dank für deine Hilfe!
Judith

Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Sepp
Geschrieben am: 28.07.2015 23:03:49
Hallo Judith,
also bei mir läuft das Makro, egal ob die Datei offen oder nicht ist. Wenn sie nicht geöffnet ist wird sie geöffnet.

Gruß Sepp


Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Judith
Geschrieben am: 28.07.2015 23:11:42
Hallo Sepp,
Mist, mir gehen die Ideen aus. Ist die Summary Datei zu, dann läuft es wie am Schnürchen, aber ist die Datei bereits offen und ich führe das Makro aus, dann passiert nichts (auch keine Fehlermeldung, sondern einfach nichts). Aber vielen Dank für deinen Input!
viele Grüße,
Judith

Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Sepp
Geschrieben am: 28.07.2015 23:22:25
Hallo Judith,
vielleicht liegts am Netzwerpfad, ändere mal folgende Zeile

If objWB.FullName Like "*" & Mid(Folder, 3) & Wkbk Then

Gruß Sepp


Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Judith
Geschrieben am: 28.07.2015 23:29:38
Hallo Sepp,
wieder nichts. Sobald die Summary Datei offen ist, passiert nichts mit dem Macro. Ich verstehe es absolut nicht!Aber trotzdem vielen, vielen Dank!
Viele Grüße,
Judith

Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Sepp
Geschrieben am: 28.07.2015 23:34:02
Hallo nochmal,
dann prüfen wir nur den Dateinamen ohne Pfad.

If objWB.Name = Wkbk Then

Gruß Sepp


Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Judith
Geschrieben am: 28.07.2015 23:43:31
WOOT WOOT - jetzt funktioniert es. Unglaublich !!Ich hatte die Hoffnung schon vollkommen aufgegeben. Nun noch eine letzte Frage: weisst du was passiert, wenn jemand anders die Datei geöffnet hat? Die Summary Datei ist auf dem Server und es kann ab und zu Phasen geben, in denen jemand eventuell darin arbeitet und vergisst die Datei zu schliessen.
Nochmals vielen herzlichen Dank, dass ist wirklich super !

Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Sepp
Geschrieben am: 28.07.2015 23:52:22
Hallo Judith,
weiß aber nicht, ob das im netzwerk läuft!

' **********************************************************************
' Modul: Save_budget_tabs_in_summary Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Enum XL_FILESTATUS
  XL_UNDEFINED = -1
  XL_CLOSED
  XL_OPEN
  XL_DONTEXIST
End Enum

Sub Save_budget_in_summary()
Dim ws As Worksheet, wscnt As Long, cnt As Long, objWB As Workbook, bolOpen As Boolean
Const Folder = "\\vwoahess100\common\fin\FINPLAN\PR64\Group Functions\" 'Path where summary file is located
Const Wkbk = "Group_Functions_Summary.xlsm" 'Name of Summary workbook

On Error GoTo ErrExit

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

wscnt = Worksheets.Count

For Each objWB In Application.Workbooks
  If objWB.Name = Wkbk Then
    bolOpen = True
    Exit For
  End If
Next

If Not bolOpen Then
  If FileStatus(Folder & Wkbk) = XL_OPEN Then
    MsgBox "Die Summary-Datei ist von einem anderen Benutzer geöffnet", vbExclamation, "Abbruch"
    GoTo ErrExit
  End If
  Set objWB = Workbooks.Open(Folder & Wkbk)
End If

If Not objWB Is Nothing Then
  For Each ws In ThisWorkbook.Worksheets
    With ws
      If .Index < wscnt - 3 Then 'Input file has 4 input_tabs (if sheet index is smaller than 1 (which means no budget sheets), then do nothing
        If SheetExist(CStr(.Name), objWB) Then objWB.Sheets(.Name).Delete
        .Copy After:=objWB.Sheets(objWB.Sheets.Count) 'Copy the sheets at the end of the workbook
        cnt = cnt + 1
      End If
    End With
  Next
  objWB.Close (True) 'summary workbook will be closed and saved
  MsgBox cnt & " sheets copied to " & Wkbk 'Messagebox how man sheets were copied to summary sheet
End If

ErrExit: 'No instructions if error occurs => nothing will be done from VBA => Additional VBA error message will not be displayed

On Error GoTo 0

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

Set objWB = Nothing
End Sub


Private Function FileStatus(xlFile As String) As XL_FILESTATUS
Dim File As Integer

On Error Resume Next

File = FreeFile

Open xlFile For Input Access Read Lock Read As #File
Close #File

Select Case Err.Number
  Case 0: FileStatus = XL_CLOSED
  Case 70: FileStatus = XL_OPEN
  Case 76: FileStatus = XL_DONTEXIST
  Case Else: FileStatus = XL_UNDEFINED
End Select

End Function


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
  If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function


Gruß Sepp


Bild

Betrifft: AW: Blätter in andere Arbeitsmappe kopieren
von: Judith
Geschrieben am: 28.07.2015 23:58:01
Nein, das mag es nicht. In dem Fall kopiert es alle Tabellenblätter. Egal, vielen vielen Dank für deine Hilfe. Das macht es deutlich einfacher für mich !

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Blätter in andere Arbeitsmappe kopieren "