Problem mit Close Befehl

Option Explicit Sub tt() Dim fs, n As Integer, zeiQ As Long, zeiZ As Long, wsZ As Worksheet Set fs = Application.FileSearch Set wsZ = ActiveSheet With fs .LookIn = "C:\My Documents" .Filename = "*.xls" .Execute For n = 1 To .FoundFiles.Count zeiZ = ActiveSheet.Range("A65536").End(xlUp).Row + 1 If n = 1 Then zeiZ = 1 Application.EnableEvents = False Workbooks.Open .FoundFiles(n) Application.EnableEvents = True zeiQ = ActiveSheet.Range("A65536").End(xlUp).Row ActiveSheet.Range("A1:B" & zeiQ).Copy wsZ.Activate wsZ.Cells(zeiZ, 1).Select wsZ.Paste Link:=True Workbooks(.FoundFiles(n)).Close savechanges:=False Next n End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Reinhard!
Ungetestet!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
Sub tt()
Dim fs, n As Integer, zeiQ As Long, zeiZ As Long
Dim wsZ As Worksheet, wsQ As Worksheet, wbQ As Workbook
Dim lngCalculation As Long

Set fs = Application.FileSearch
Set wsZ = ActiveSheet

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  lngCalculation = .Calculation
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

With fs
  .LookIn = "C:\My Documents"
  .Filename = "*.xls"
  .Execute
  For n = 1 To .FoundFiles.Count
    zeiZ = wsZ.Range("A65536").End(xlUp).Row + 1
    If n = 1 Then zeiZ = 1
    Set wbQ = Workbooks.Open(.FoundFiles(n))
    Set wsQ = wbQ.ActiveSheet
    zeiQ = wsQ.Range("A65536").End(xlUp).Row
    wsQ.Range("A1:B" & zeiQ).Copy wsZ.Cells(zeiZ, 1)
    wbQ.Close False
    Set wbQ = Nothing
    Set wsQ = Nothing
  Next
End With

ErrExit:

Set wsZ = Nothing
Set fs = Nothing

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = lngCalculation
  .Cursor = xlDefault
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Reinhard!
Dann greifen wir auf Trick 17 zurück;-))

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
Sub tt()
Dim fs, n As Integer, zeiQ As Long, zeiZ As Long
Dim wsZ As Worksheet, wsQ As Worksheet, wbQ As Workbook
Dim lngCalculation As Long

Set fs = Application.FileSearch
Set wsZ = ActiveSheet

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  lngCalculation = .Calculation
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

With fs
  .LookIn = "C:\My Documents"
  .Filename = "*.xls"
  .Execute
  For n = 1 To .FoundFiles.Count
    zeiZ = wsZ.Range("A65536").End(xlUp).Row + 1
    If n = 1 Then zeiZ = 1
    Set wbQ = Workbooks.Open(.FoundFiles(n))
    Set wsQ = wbQ.ActiveSheet
    zeiQ = wsQ.Range("A65536").End(xlUp).Row
    wsQ.Range("A1:B" & zeiQ).Copy
    wsZ.Cells(zeiZ, 1).PasteSpecial xlValues
    wsZ.Paste Link:=True
    Application.CutCopyMode = False
    wbQ.Close False
    Set wbQ = Nothing
    Set wsQ = Nothing
  Next
End With

ErrExit:

Set wsZ = Nothing
Set fs = Nothing

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = lngCalculation
  .Cursor = xlDefault
End With

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Sub ttt() Dim fs, n As Integer, zeiQ As Long, zeiZ As Long, wsZ As Worksheet, wbQ As Workbook Application.ScreenUpdating = False Application.DisplayAlerts = False 'wegen Abfage Zwischenablage leeren Set fs = Application.FileSearch Set wsZ = ActiveSheet With fs .LookIn = "C:\My Documents" .Filename = "*.xls" .Execute For n = 1 To .FoundFiles.Count zeiZ = ActiveSheet.Range("A65536").End(xlUp).Row + 1 If n = 1 Then zeiZ = 1 Application.EnableEvents = False Set wbQ = Workbooks.Open(.FoundFiles(n)) Application.EnableEvents = True zeiQ = ActiveSheet.Range("A65536").End(xlUp).Row ActiveSheet.Range("A1:B" & zeiQ).Copy wsZ.Activate wsZ.Cells(zeiZ, 1).Select wsZ.Paste Link:=True wbQ.Close savechanges:=True 'Workbooks(.FoundFiles(n)).Close savechanges:=False Next n End With Range("A1").Select Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread