Blätter in andere Arbeitsmappe kopieren

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

Beliebteste Forumthreads (12 Monate)

Blätter in andere Arbeitsmappe kopieren

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Blätter in andere Arbeitsmappe kopieren

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread