Arbeitsmappe schließen

Hallo,
ich komme nicht drauf ...
Ich habe einen Ordner in dem es eine Menge xls gibt die VBA-Code enthalten, der passwortgeschützt ist. Nun brauche ich die Dateien (bzw. jeweils ein Blatt daraus) unbedingt ohne Code.
Ich habe mir gedacht alle Dateien aus einer Mappe heraus automatisch nacheinander zu öffnen und das entscheidende Blatt in eine neue Arbeitsmappe zu kopieren. Die 'überflüssigen' xls will ich später manuell löschen.
So sieht mein Code aus:
StrVerzeichnis = ActiveWorkbook.Path & "\"
StrTyp = "*.xls"
StrDateiname = Dir(StrVerzeichnis & "\" & StrTyp)
Do While StrDateiname ""
Workbooks.Open Filename:=StrVerzeichnis & StrDateiname
Application.DisplayAlerts = False
For Each WS In ActiveWorkbook.Sheets
If WS.Name = "Aktuelle Rechnung" Then
NeuerName = StrVerzeichnis & "_neu" & StrDateiname
Sheets("Aktuelle Rechnung").Copy
With ActiveWorkbook
.SaveAs Filename:=NeuerName
.Close
End With
End If
Next WS
ActiveWorkbook.Close False
StrDateiname = Dir
Loop
Das Kopieren der Blätter in neue Arbeitsmappen und schließen derselben funktioniert auch ... aber ich kann die Arbeitsmappe aus der das Blatt kopiert wird nicht schließen ("ActiveWorkbook.Close False" führt zu "Index außerhalb des gültigen Bereichs" und alle anderen Versuche haben auch nicht funktioniert).
Hat jemand von Euch eine Idee?
Danke und Grüße,
Michael

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Michael,

woher der Fehler kommt, kann ich nicht sagen, ich würde aber sauber referenzieren, dann sollte es laufen.

Sub copySheetToWb()
  Dim objWb As Workbook, WS As Worksheet
  Dim strVerzeichnis As String, strTyp As String, strDateiname As String
  Dim lngCalc As Long

  On Error GoTo ErrExit

  With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
  End With

  strVerzeichnis = ActiveWorkbook.Path & "\"
  strTyp = "*.xls"
  strDateiname = Dir(strVerzeichnis & "\" & strTyp)

  Do While strDateiname <> ""
    Set objWb = Workbooks.Open(Filename:=strVerzeichnis & strDateiname)
    For Each WS In objWb.Sheets
      If WS.Name = "Aktuelle Rechnung" Then
        WS.Copy
        With ActiveWorkbook
          .SaveAs Filename:=strVerzeichnis & "_neu" & strDateiname
          .Close
        End With
        Exit For
      End If
    Next
    objWb.Close False
    strDateiname = Dir
  Loop



  ErrExit:
  With Err
    If .Number <> 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
      .Description & vbLf & vbLf & "In Prozedur (copySheetToWb) in Modul Modul3", _
      vbExclamation, "Fehler in Modul3 / copySheetToWb"
  End With

  With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayAlerts = True
    .Calculation = lngCalc
  End With

  Set objWb = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread