Code optimieren
Kai
ich bastle grade an einem Makro, das aber (so scheint es mir) stark verbesserungswürdig ist.
es gibt für jeden Kollegen eine Arbeitszeitdatei in der Anwesenheit reinschreibt und zu jeder tätigkeit die er macht die tätigkeitsnummer beginn der tätigkeit, ende und eine beschreibung einträgt.
zu jeder tätigkeit gibt es eine Tätigkeitsdatei.
Mein vba das ich aus der Tätigkeitsdatei starte macht folgendes. öffnet alle MA dateien (ca. 20) sucht die tätigkeit und kopiert die Infos heraus. Leider dauert das ewig. wer kann mir nen Tip geben? Hier der Code:
'Option Explicit
Sub tst()
Dim ErsteFreieZelle As Long
Dim aktuellerBereich As Range
Dim tätigkeit As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
tätigkeit = 0
tätigkeit = ActiveSheet.Range("b1").Value
Range("A3:F12").ClearContents
Workbooks.Open Filename:= _
"C:\Temp\mitarbeiter\ma1.xlsx" '" & zelle.Value & ".xlsx"
Set aktuellerBereich = Range("I7:R368")
aktuellerBereich.Select
For Each zelle In aktuellerBereich.Cells
Application.CutCopyMode = False
zelle.Select
If zelle.Value = tätigkeit Then
ActiveCell.Offset.Range("B1,C1,D1,G1,H1").Select
Selection.Copy
Workbooks(tätigkeit & ".xlsm").Activate
ErsteFreieZelle = Range("A1").End(xlDown).Row + 1
Range("A" & ErsteFreieZelle).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Workbooks("ma1.xlsx").Activate
End If
Next zelle
Workbooks("ma1.xlsx").Close
Workbooks(tätigkeit & ".xlsm").Activate
Workbooks.Open Filename:= _
"C:\Temp\mitarbeiter\ma2.xlsx '" & zelle.Value & ".xlsx"
Set aktuellerBereich = Range("I7:R368")
'aktuellerBereich.Select
For Each zelle In aktuellerBereich.Cells
Application.CutCopyMode = False
zelle.Select
If zelle.Value = tätigkeit Then
ActiveCell.Offset.Range("B1,C1,D1,G1,H1").Select
Selection.Copy
Selection.Copy
Workbooks(tätigkeit & ".xlsm").Activate
ErsteFreieZelle = Range("A1").End(xlDown).Row + 1
Range("A" & ErsteFreieZelle).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues
Workbooks("ma2.xlsx").Activate
End If
Next zelle
Workbooks("ma1.xlsx").Close
Workbooks(tätigkeit & ".xlsm").Activate
MsgBox "Daten aktualisiert"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ActiveWorkbook.Save
End Sub
Gruß Kai