Mein Post von vorhin kam wohl nicht an. Also das wird jetzt schwierig. Arbeite mit ner deutschen Version und dem guten alten Excel 2003. :-)
Kann deshalb nicht genau den Fehler nachvollziehen. Bei mir läuft es super.
Wir könnten auch von der Formel weggehen und das alles mit einer Schleife berechnen. Wird ggf. die LAufzeit etwas erhöhen?! Hätte ich aber schon da.
Vorteil wäre auch, dass nicht immer Formeln drin stehen, die Excel beim erneuten Öffnen (falls du mehrfach auf die Datei zugreist) aktualisieren musst. Das hat bei mir unglaublich Zeit gekostet. Zudem ist die Dateigröße ziemlich schnell gewachsen (nach 20 Durchläufen 10 MB) - was dann nochmal Zeit gekostet hat. Deshalb der Vorschlag falls du das Speichern nicht brauchst ggf. rausnehmen - wobei es bei der Version unten ohne Formel nicht ganz so problematisch ist (zumindest vom Anwachsen der Dateigröße), speichern kostet aber halt immer nen bissl mehr Zeit.
Sub Spread_CalcExp()
'Open Files
Dim Source As String
Dim StrFile As String
Const csPath As String = "C:\Users\Maximilian\Documents\Studium\Bachelor Arbeit\Data\Aggr_Orders_Match\"
Dim i As Integer
Dim j As Integer
Dim objRange As Range
Dim Spalte As Integer
Dim Ausgang As String
Dim Tab2 As String
Dim Formel As String
Dim Tabe As String
Dim Nam2 As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'do not forget last backslash in source directory.
Source = "C:\Users\Maximilian\Documents\Studium\Bachelor Arbeit\Data\"
StrFile = Dir(Source & "*.xls")
'die Datei aus der das Makro startet und die Werte eingetragen werden
Ausgang = "Order_Spread_Export.xlsm"
Do While Len(StrFile) > 0
'sucht die aktuelle Spalte in der Ausgangsdatei
Spalte = Workbooks(Ausgang).Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
'öfnet die erste Datei
Workbooks.Open Filename:=Source & StrFile
' Prozedur Spread Start
Sheets.Add After:=ActiveSheet
'Name der eingefügten Tabelle
Tabe = Workbooks(StrFile).ActiveSheet.Name
Tab2 = Workbooks(StrFile).Worksheets(2).Name
On Error Resume Next ' mußte ich reinnehmen, da ich nicht 6601 befüllt habe und sonst eine Fehlermeldung div durch 0 erhalte
' nun berechnen wir halt selber
For i = 2 To 6601
Workbooks(StrFile).Worksheets(Tabe).Cells(i, 1) = 2 * (Workbooks(StrFile).Worksheets(Tab2).Cells(i, 2) - Workbooks(StrFile).Worksheets(Tab2).Cells(i, 3)) / (Workbooks(StrFile).Worksheets(Tab2).Cells(i, 2) + Workbooks(StrFile).Worksheets(Tab2).Cells(i, 3))
Next i
Workbooks(StrFile).Worksheets(Tabe).Range("A1").Value = "Relative Spread" 'Einfügen einer Überschrift
' die Formatierungen
Workbooks(StrFile).Worksheets(Tabe).Range("A:A").Style = "Percent"
Workbooks(StrFile).Worksheets(Tabe).Range("A:A").NumberFormat = "0.0000%"
' Prozedur Spread Ende
'Ab hier soll die Range("A:A") in das Workbook("Order_Spread_Export") in Sheet1 in die nächste leere Spalte kopiert werden.
' Danach soll sich dass Variable Sheet schließen und ein neues Sheet bearbeitet werden
Workbooks(StrFile).Worksheets(Tabe).Range("A:A").Copy
'Odner Order_Spread_Export.xls aktivieren und dann die Werte einfügen
Workbooks(Ausgang).Activate
'jetzt einfügen, letzter Wert war in Spalte deshalb Spalte +1
Workbooks(Ausgang).Worksheets(1).Columns(Spalte + 1).PasteSpecial (xlPasteValuesAndNumberFormats)
Workbooks(StrFile).Close savechanges:=True
' nächste Datei holen
StrFile = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Die sollte nun auch im englishen Excel laufen. :-) Hoffe ich zumindest.
Gruß Matthias
|