Anzeige
Archiv - Navigation
896to900
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
896to900
896to900
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

makro optimieren (geschwindigkeit)

makro optimieren (geschwindigkeit)
23.08.2007 14:53:00
chris
Hallo VBA profis,
ich habe heute ein Problem das mit der geschwindigkeit meines Makros zu tun hat ....
ich habe hier ein Makro das mir von einer datei in die andere Daten überträgt.
Aber leider braucht das makro sehr lange :(
Es ist sehr viel Code aber ich hoffe ihr habt vielleicht trotzdem tipps für mich.
Wäre wirklich super.
Noch eine info ..
ganz oben bei dem Aufruf der eizelnen makros steht also habe ich eingetragen ..
"Application.ScreenUpdating = False"
aber das hilft nicht besonders viel.
Danke gruß Christian
Public old_wb

Sub uebertrag_L5_1(x, s, f)
Set old_wb = ActiveWorkbook
'öffnet MAE
Workbooks.Open ("Runden 5.1.xls")
Set new_wb = ActiveWorkbook
akt_sheet_name_monat = MonthName(Month(datum.Calendar1.Value))
new_wb.Worksheets(akt_sheet_name_monat).Select
'suchen Spalte mit akt Datum neue Mappe
For xx = 4 To 200
If Cells(6, xx) = datum.Calendar1.Value Then
Exit For
Else
End If
Next
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 1
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(20, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(20, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(20, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 8
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(176, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(176, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(176, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 12
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(173, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(173, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(173, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 13
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(175, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(175, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(175, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 15
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(177, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(177, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(177, xx + 1) = "1"
Else
End If
'ActiveWorkbook.Close False
End Sub


'-------------------------------------- ENDE 5_1 -----------------------------------------
'-------------------------------------- ENDE 5_1 -----------------------------------------


Sub uebertrag_L5_2(x, s, f)
'Set old_wb = ActiveWorkbook
'öffnet MAE
Workbooks.Open ("Runden 5.2.xls")
Set new_wb = ActiveWorkbook
akt_sheet_name_monat = MonthName(Month(datum.Calendar1.Value))
new_wb.Worksheets(akt_sheet_name_monat).Select
'suchen Spalte mit akt Datum neue Mappe
For xx = 4 To 200
If Cells(6, xx) = datum.Calendar1.Value Then
Exit For
Else
End If
Next
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 1
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(20, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(20, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(20, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 8
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(176, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(176, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(176, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 12
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(173, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(173, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(173, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 13
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(175, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(175, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(175, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 15
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(177, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(177, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(177, xx + 1) = "1"
Else
End If
'ActiveWorkbook.Close False
End Sub


'-------------------------------------- ENDE 5_2 -----------------------------------------
'-------------------------------------- ENDE 5_2 -----------------------------------------


Sub uebertrag_L5_3(x, s, f)
'Set old_wb = ActiveWorkbook
'öffnet MAE
Workbooks.Open ("Runden 5.3.xls")
Set new_wb = ActiveWorkbook
akt_sheet_name_monat = MonthName(Month(datum.Calendar1.Value))
new_wb.Worksheets(akt_sheet_name_monat).Select
'suchen Spalte mit akt Datum neue Mappe
For xx = 4 To 200
If Cells(6, xx) = datum.Calendar1.Value Then
Exit For
Else
End If
Next
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 1
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(20, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(20, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(20, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 8
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(176, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(176, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(176, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 12
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(173, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(173, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(173, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 13
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(175, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(175, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(175, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 15
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(177, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(177, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(177, xx + 1) = "1"
Else
End If
'ActiveWorkbook.Close False
End Sub


'-------------------------------------- ENDE 5_3 -----------------------------------------
'-------------------------------------- ENDE 5_3 -----------------------------------------


Sub uebertrag_L5_4(x, s, f)
'Set old_wb = ActiveWorkbook
'öffnet MAE
Workbooks.Open ("Runden 5.4.xls")
Set new_wb = ActiveWorkbook
akt_sheet_name_monat = MonthName(Month(datum.Calendar1.Value))
new_wb.Worksheets(akt_sheet_name_monat).Select
'suchen Spalte mit akt Datum neue Mappe
For xx = 4 To 200
If Cells(6, xx) = datum.Calendar1.Value Then
Exit For
Else
End If
Next
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 1
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(20, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(20, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(20, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 8
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(176, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(176, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(176, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 12
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(173, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(173, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(173, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 13
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(175, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(175, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(175, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 15
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(177, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(177, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(177, xx + 1) = "1"
Else
End If
'ActiveWorkbook.Close False
End Sub


'-------------------------------------- ENDE 5_4 -----------------------------------------
'-------------------------------------- ENDE 5_4 -----------------------------------------


Sub uebertrag_L5_5(x, s, f)
'Set old_wb = ActiveWorkbook
'öffnet MAE
Workbooks.Open ("Runden 5.5.xls")
Set new_wb = ActiveWorkbook
akt_sheet_name_monat = MonthName(Month(datum.Calendar1.Value))
new_wb.Worksheets(akt_sheet_name_monat).Select
'suchen Spalte mit akt Datum neue Mappe
For xx = 4 To 200
If Cells(6, xx) = datum.Calendar1.Value Then
Exit For
Else
End If
Next
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 1
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(20, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(20, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(20, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 8
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(176, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(176, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(176, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 12
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(173, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(173, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(173, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 13
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(175, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(175, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(175, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 15
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(177, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(177, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(177, xx + 1) = "1"
Else
End If
'ActiveWorkbook.Close False
End Sub


'-------------------------------------- ENDE 5_5 -----------------------------------------
'-------------------------------------- ENDE 5_5 -----------------------------------------


Sub uebertrag_L5_6(x, s, f)
'Set old_wb = ActiveWorkbook
'öffnet MAE
Workbooks.Open ("Runden 5.6.xls")
Set new_wb = ActiveWorkbook
akt_sheet_name_monat = MonthName(Month(datum.Calendar1.Value))
new_wb.Worksheets(akt_sheet_name_monat).Select
'suchen Spalte mit akt Datum neue Mappe
For xx = 4 To 200
If Cells(6, xx) = datum.Calendar1.Value Then
Exit For
Else
End If
Next
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 1
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(20, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(20, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(20, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(20, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 8
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(176, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(176, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(176, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(176, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 12
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(173, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(173, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(173, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(173, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 13
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(175, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(175, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(175, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(175, xx + 1) = "1"
Else
End If
tx = old_wb.ActiveSheet.Range("sp5_1").Row + 15
If old_wb.ActiveSheet.Cells(tx, x) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + s) = old_wb.ActiveSheet.Cells(tx, x) * 60 '
new_wb.ActiveSheet.Cells(177, xx + s + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 1) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx + f) = old_wb.ActiveSheet.Cells(tx, x + 1) * 60 '
new_wb.ActiveSheet.Cells(177, xx + f + 1) = "1"
Else
End If
If old_wb.ActiveSheet.Cells(tx, x + 2) * 60 > 0 Then
new_wb.ActiveSheet.Cells(177, xx) = old_wb.ActiveSheet.Cells(tx, x + 2) * 60 '
new_wb.ActiveSheet.Cells(177, xx + 1) = "1"
Else
End If
'ActiveWorkbook.Close False
End Sub


'-------------------------------------- ENDE 5_6 -----------------------------------------
'-------------------------------------- ENDE 5_6 -----------------------------------------

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

Betreff
Datum
Anwender
Anzeige
AW: makro optimieren (geschwindigkeit)
23.08.2007 14:58:00
Renee
Hi Chris,
Im Ernst, meinst Du es hat jemand Zeit und v.a. Lust dieses Code-Monstrum zu untersuchen?
Versuch mal:
Am Anfang

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'... dann Dein Monstercode und vor dem Ende
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True


Greetz Renee

AW: makro optimieren (geschwindigkeit)
23.08.2007 15:14:00
chris
Danke renee,
habe ich mir schon gedacht weil der code so lange ist ..
Habe mir eben gedacht weil die einzelnen module sind ja kleiner evtl. einer einen guten Tipp hat.
Danke auch für deinen der aber nicht viel geholfen hat.
gruß Christian

Anzeige
AW: makro optimieren (geschwindigkeit)
23.08.2007 15:21:23
chris
Stopp danke renee
Alles ok mit dem Code !

AW: makro optimieren (geschwindigkeit)
23.08.2007 15:21:44
HalMar
Hi chris,
Vielleicht hilft es wenn du einfach mal sagst was du erreichen willst, also welche Datenbereiche mit welchen Kriterien usw., dann kann dir vielleicht jemand bei einem kürzeren Code helfen...
Lg Mario

Tja, Renee ist eben DIE Beste ^^
23.08.2007 15:50:00
HalMar

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige