VBA-Code optimieren
14.12.2015 20:56:19
Dennis
ich habe mir mein "Wissen" mit Hilfe dieses Forums angeeignet und bastel mir meine Makros anhand alter zusammen. Bei folgendem Makro komme ich leider an eine Grenze, da der Vorgang zu lange dauert.
Zur Erläuterung:
Es handelt sich um ein Tabellenblatt (Management Cockpit), welches in der ersten Zeile verschiedene Meilensteine hat und in der ersten Spalte verschiedene Projekte/Kunden. Wenn in einem Projekt ein Meilenstein benötigt wird, steht entsprechend ein Zieldatum in der Zelle (Ausgelesen aus einer projektspezifischen Excel "Projektübersicht"). Je nachdem ob Verzug vorliegt, werden die Zellen farblich markiert. Bei Klicken auf eine Schaltfläche "Aktualisieren" werden aus der projektspezifischen Datei die neuen Zieldaten genommen, bzw. die Fertigsstellungsdaten verglichen, und in das "Management Cockpit" übernommen und entsprechend farblich markiert.
Der Vorgang des Öffnens der Datei und der Abgleich der Daten dauert leider recht lange und ich hoffe es gibt eine schnellere Lösung!
Private Sub CommandButton1_Click()
Dim bereich As Range
Dim ExcelWorkbook As Excel.Workbook
Dim strPfad As String
Dim zeilen1 As Range
Dim bereich1 As Range
Dim spalte
Dim suchen
Dim suchen2
Dim zeile
Dim verzug
Dim termin
Dim fertig
Set ExcelObjekt = CreateObject("Excel.Application")
For i = 3 To Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row
If Dir(ThisWorkbook.Path & "\" & Cells(i, 1).Value & "_" & Cells(i, 2).Value & "\") "" _
Then
strPfad = (ThisWorkbook.Path & "\" & Cells(i, 1).Value & "_" & Cells(i, 2).Value & "\" & " _
_
Projektübersicht.xlsm")
Set ExcelWorkbook = ExcelObjekt.Workbooks.Open(strPfad)
Set bereich1 = ExcelWorkbook.Worksheets(1).Range("A2:A20")
For Each zeile1 In bereich1
Select Case zeile1.Value
Case Is ""
verzug = ExcelWorkbook.Worksheets(1).Cells(zeile1.Row, 3).Value
termin = ExcelWorkbook.Worksheets(1).Cells(zeile1.Row, 4).Value
For suchen = 1 To 20
If Workbooks("Management Cockpit.xlsm").Worksheets(1).Cells(1, suchen).Value = _
_
zeile1.Value Then
spalte = suchen
End If
Next
For suchen2 = 1 To 50
If Workbooks("Management Cockpit.xlsm").Worksheets(1).Cells(suchen2, 1).Value = _
_
Workbooks("Management Cockpit.xlsm").Worksheets(1).Cells(i, 1).Value And Cells(suchen2, 2). _
Value = Cells(i, 2).Value Then
zeile = suchen2
End If
Next
Workbooks("Management Cockpit.xlsm").Worksheets(1).Cells(zeile, spalte).Value = _
termin
If verzug = "1" Then
Workbooks("Management Cockpit.xlsm").Worksheets(1).Cells(zeile, spalte).Interior. _
ColorIndex = 3
End If
If termin = "Termin fehlt" Then
GoTo termin
End If
If ExcelWorkbook.Worksheets(1).Cells(zeile1.Row, 5).Value "" And ExcelWorkbook. _
_
Worksheets(1).Cells(zeile1.Row, 4).Value "Termin fehlt" And verzug = "0" Then
Workbooks("Management Cockpit.xlsm").Worksheets(1).Cells(zeile, spalte).Interior. _
ColorIndex = 4
End If
termin:
Case Else
End Select
Next
ExcelWorkbook.Close savechanges:=False
End If
Next
Vielen Dank!