AW: lass die Frage offen...
17.09.2009 15:28:15
fcs
Hallo Gunther,
ein Problem in deiner Version ist, dass du Cells.Selection benutzt und danach dann Copy und PasteSpecial benutzt, um Formeln durch Werte zu erstzen. Das braucht natürlich enorme Reserven.
Du solltest hier mit UsedRange arbeiten.
wsZiel.Sheets(strSheet).Activate
ActiveSheet.UsedRange.Copy
ActiveSheet.UsedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
wsZiel.Sheets(strSheet).Name = strZielSheet
wsZiel.Sheets(strZielSheet).Activate
Ansonsten funktioniert deine Prozedur auch wenn sie elendig viele Select- und Activate-Anweisungen enthält.
Ich würde die Prozedur komplett umstricken, inklusive geordneter Fehlerbehandlung.
Gruß
Franz
Sub Sheet_Copy()
Dim strPfad As String, strSheet As String, strZieldatei As String
Dim strQuelldatei As String, strBerechnungsWert As String, strZielSheet As String
Dim intGes As Long, intStartPos As Long
Dim lgLaenge As Long, i As Long
Dim wsMakro As Worksheet, wbMakro As Workbook
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim rgGes As Range
Dim gvar As Integer
Dim intFehler As Long
On Error GoTo Fehler
With Application
Set wbMakro = .ActiveWorkbook
Set wsMakro = .ActiveWorkbook.ActiveSheet
.EnableEvents = False
gvar = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.Cursor = xlWait
.StatusBar = "Kopiervorgang wird eingeleitet..."
intFehler = 1
'Zieldatei-Namen-auslesen
With wsMakro
strPfad = .Range("Pfad") & "\"
strSheet = .Range("Sheet")
strZieldatei = .Range("Datei")
End With
intFehler = 2
'Prüfen, ob Zieldatei-Name schon vorhanden
If Not Dir(strPfad & strZieldatei) = "" Then
MsgBox "Eine Datei mit dem Namen: " & strZieldatei _
& " ist bereits vorhanden. Bitte das Problem vor dem nächsten Aufruf" _
& "des Programms lösen!", vbCritical
Call cleansweep(gvar)
Exit Sub
End If
intFehler = 3
Set rgGes = wsMakro.Range("Quelle").CurrentRegion
intGes = rgGes.Rows.Count - 1
.StatusBar = "Öffnen und kopieren der Zieldatei: " & strZieldatei
'Dateiliste abarbeiten
For i = 2 To rgGes.Rows.Count 'Schleifenzähler ggf. anpassen
' For i = 1 To rgGes.Rows.Count-1 'alternative
intFehler = 4
'Dateiname einlesen
strQuelldatei = rgGes(i, 1)
lgLaenge = Len(strQuelldatei)
'neuen Blattnamen aus Dateiname erzeugen
strZielSheet = Mid(strQuelldatei, 7, (lgLaenge - 11))
.StatusBar = "Einfügen der Datei: " & strQuelldatei
intFehler = 5
Set wbQuelle = .Workbooks.Open(Filename:=strPfad & "\" & strQuelldatei, _
UpdateLinks:=0, ReadOnly:=True)
With wbQuelle
intFehler = 6
'Blatt aus Quelle kopieren
If wbZiel Is Nothing Then
'Neue Ziel-Arbeitsmappe für kopierte Blätter erstellen bei 1. Datei
.Sheets(strSheet).Copy
Set wbZiel = ActiveWorkbook
Else
.Sheets(strSheet).Copy Before:=wbZiel.Sheets(1)
End If
End With
wbQuelle.Close SaveChanges:=False
Set wbQuelle = Nothing
intFehler = 7
'Formeln durch Werte ersetzen Ziel-Blatt umbenennen
With wbZiel.Sheets(1)
.UsedRange.Value = .UsedRange.Value
' .UsedRange.Copy
' .UsedRange.Value.PasteSpecial Paste:=xlPasteValues
' Range("A1").Select
.Name = strZielSheet
End With
Next i
'Zieldatei speichern
If wbZiel Is Nothing Then
MsgBox "Es wurden keine Dateien kopiert"
Else
intFehler = 8
'Speichern der Zieldatei
wbZiel.SaveAs Filename:=strPfad & strZieldatei, addtomru:=True
wbZiel.Close SaveChanges:=False
Set wbZiel = Nothing
End If
End With
wbMakro.Activate
wsMakro.Activate
Call cleansweep(gvar)
MsgBox "Es wurden die Daten von " & Str(intGes) & " Dateien erfolgreich übertragen!", _
vbInformation
Err.Clear
Fehler:
With Err
If .Number 0 Then
Select Case .Number
Case 99999
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr. " & .Number & vbLf & .Description & vbLf & "intFehler = " _
& intFehler
If Not wbQuelle Is Nothing Then wbQuelle.Close SaveChanges:=False
Call cleansweep(gvar)
End Select
End If
End With
Set rgGes = Nothing
Set wbZiel = Nothing
End Sub