Vorlagen kopieren extrem langsam

Sub Vorl_Import() Dim WkbQ As Workbook Dim sFile As String Dim i As Integer, wsName As String, sName As String Dim ShGrund As Worksheet, wks As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False Set ShGrund = Worksheets("Grunddaten") sFile = ShGrund.Range("A22") sName = ShGrund.Range("A23") 'sFile = "G:\Vorlagen\QuellVorlagen.xls" 'sName = "Vorl" If Dir(sFile) = "" Then Beep MsgBox "Datei wurde nicht gefunden!" Exit Sub End If For Each wks In Worksheets If InStr(wks.Name, sName) > 0 Then wks.Delete Next wks On Error GoTo ERRORHANDLER Application.EnableEvents = False Set WkbQ = Workbooks.Open(sFile, False) For Each wks In WkbQ.Worksheets With wks 'QuellVorlagen If Left(.Name, 4) = sName Then '## -Fehler#########- wenn aktiviert,wird die Quelldatei nicht geschlossen ' .Visible = False .Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) End If End With Next WkbQ.Close savechanges:=False 'Call Vorl_NotVisible ERRORHANDLER: Application.DisplayAlerts = False Application.EnableEvents = True Application.ScreenUpdating = True End Sub

Sub Vorl_NotVisible() Dim wks As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False For Each wks In ThisWorkbook.Worksheets With wks 'QuellVorlagen If Left(.Name, 4) = "Vorl" Then .Visible = False End If End With Next Application.ScreenUpdating = True Application.DisplayAlerts = True End

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Peter,
ich hab dein Makro mal so umgestellt und angepasst,
dass alle Blätter in einem Rutsch in der aktiven Datei gelsöcht werden und alle Vorlageblätter in einem Kopiervorgang übertragen werden.
Zusätzlich wird während der Aktionen der Berechnungsmodus deaktiviert.
Ich hab das Makro unter Excel 2010 erstellt und getestet.
Gruß
Franz

Sub Vorl_Import()
Dim WkbQ As Workbook, wkbThis As Workbook, arrSheets() As Variant
Dim sFile As String
Dim i As Integer, wsName As String, sName As String
Dim ShGrund As Worksheet, wks As Worksheet
Dim StatusCalc As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set wkbThis = ActiveWorkbook
Set ShGrund = wkbThis.Worksheets("Grunddaten")
sFile = ShGrund.Range("A22")
sName = ShGrund.Range("A23")
'sFile = "G:\Vorlagen\QuellVorlagen.xls"
'sName = "Vorl"
If Dir(sFile) = "" Then
Beep
MsgBox "Datei wurde nicht gefunden!"
Exit Sub
End If
i = 0
For Each wks In wkbThis.Worksheets
If InStr(wks.Name, sName) > 0 Then
i = i + 1
ReDim Preserve arrSheets(1 To i)
arrSheets(i) = wks.Name
End If
Next wks
If i > 0 Then
wkbThis.Sheets(arrSheets).Delete
End If
Erase arrSheets
On Error GoTo ERRORHANDLER
Set WkbQ = Workbooks.Open(sFile, False)
i = 0
For Each wks In WkbQ.Worksheets
With wks 'QuellVorlagen
If Left(.Name, 4) = sName Then
i = i + 1
ReDim Preserve arrSheets(1 To i)
arrSheets(i) = wks.Name
End If
End With
Next
If i > 0 Then
WkbQ.Sheets(arrSheets).Copy after:=wkbThis.Sheets(wkbThis.Sheets.Count)
End If
Erase arrSheets
WkbQ.Close savechanges:=False
'Call Vorl_NotVisible
ERRORHANDLER:
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub
Sub Vorl_NotVisible()
Dim wks As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each wks In ThisWorkbook.Worksheets
With wks 'QuellVorlagen
If Left(.Name, 4) = "Vorl" Then
.Visible = False
End If
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread