Code optimieren

Hallo zusammen,
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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub tst() Dim ErsteFreieZelle As Long Dim aktuellerBereich As Range Dim tätigkeit As String Dim zelle 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 '############Mitarbeiter2####################### 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 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

Option Explicit Sub tst() Dim ErsteFreieZelle As Long Dim aktuellerBereich As Range Dim tätigkeit As String Dim zelle As Range, wksm As Workbook Application.DisplayAlerts = False Application.ScreenUpdating = False On Error GoTo hell tätigkeit = ActiveSheet.Range("b1").Value 'welches Blatt? Set wksm = Workbooks(tätigkeit & ".xlsm") Range("A3:F12").ClearContents 'welches Blatt? Workbooks.Open Filename:= _ "C:\Temp\mitarbeiter\ma1.xlsx" '" & zelle.Value & ".xlsx" With Workbooks("ma1.xlsx") For Each zelle In .Range("I7:R368") Application.CutCopyMode = False If zelle.Value = tätigkeit Then zelle.Range("B1,C1,D1,G1,H1").Copy ErsteFreieZelle = wksm.Range("A1").End(xlDown).Row + 1 wksm.Range("A" & ErsteFreieZelle).PasteSpecial Paste:=xlPasteValues End If Next zelle .Close End With '############Mitarbeiter2####################### Workbooks.Open Filename:= _ "C:\Temp\mitarbeiter\ma2.xlsx '" & zelle.Value & ".xlsx" With Workbooks("ma2.xlsx") For Each zelle In .Range("I7:R368") Application.CutCopyMode = False If zelle.Value = tätigkeit Then zelle.Range("B1,C1,D1,G1,H1").Copy ErsteFreieZelle = wksm.Range("A1").End(xlDown).Row + 1 Range("A" & ErsteFreieZelle).PasteSpecial Paste:=xlPasteValues End If Next zelle .Close End With wksm.Activate wksm.Save hell: If Err.Number = 0 Then MsgBox "Daten aktualisiert" Else MsgBox Err.Number & xlcr & Err.Description End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

Sub tst() Dim ErsteFreieZelle As Long Dim aktuellerBereich As Range Dim tätigkeit As String Dim zelle As Range, wksm As Worksheet Application.DisplayAlerts = False Application.ScreenUpdating = False On Error GoTo hell tätigkeit = ActiveSheet.Range("b1").Value 'welches Blatt? Set wksm = Workbooks(tätigkeit & ".xlsm").Worksheets("Tabelle1") Range("A3:F12").ClearContents 'welches Blatt? Workbooks.Open Filename:= _ "C:\Temp\mitarbeiter\ma1.xlsx" '" & zelle.Value & ".xlsx" With Workbooks("ma1.xlsx").Worksheets("Tabelle1") For Each zelle In .Range("I7:R368") Application.CutCopyMode = False If zelle.Value = tätigkeit Then zelle.Range("B1,C1,D1,G1,H1").Copy ErsteFreieZelle = wksm.Range("A1").End(xlDown).Row + 1 wksm.Range("A" & ErsteFreieZelle).PasteSpecial Paste:=xlPasteValues End If Next zelle .Close End With '############Mitarbeiter2####################### Workbooks.Open Filename:= _ "C:\Temp\mitarbeiter\ma2.xlsx '" & zelle.Value & ".xlsx" With Workbooks("ma2.xlsx").Worksheets("Tabelle1") For Each zelle In .Range("I7:R368") Application.CutCopyMode = False If zelle.Value = tätigkeit Then zelle.Range("B1,C1,D1,G1,H1").Copy ErsteFreieZelle = wksm.Range("A1").End(xlDown).Row + 1 wksm.Range("A" & ErsteFreieZelle).PasteSpecial Paste:=xlPasteValues End If Next zelle .Close End With wksm.Worksheets("Tabelle1").Activate wksm.Parent.Save hell: If Err.Number = 0 Then MsgBox "Daten aktualisiert" Else MsgBox Err.Number & xlcr & Err.Description End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread