ich habe folgendes Anliegen an euch:
Ich habe 2 Excelmappen mit den Namen (Master und Aktuell).
In beiden Mappen sind für mich folgende Spalten wichtig:
- Projekt-ID: Master Spalte A (1) - Aktuell A (1)
- Projektstatus: Master R (18) - Aktuell L (12)
- Datum der Statusänderung: Master S (19) - Aktuell M (13)
Ziel: In der Masterdatei befindet sich ein Button, sobald ich diesen drücke, sollen passend zur jeweiligen Projekt-ID, der Status und das Datum der Statusänderung aus der Mappe (Aktuell )kommend, angepasst werden. Sprich, nur wenn eine Änderung vorgenommen wurde. Auch darf kein Status bzw. das Datum der Statusänderung überschrieben werden, falls die Projekt-ID nicht in beiden Tabellen vorhanden ist.
Hier nun mein Makro. Es funktioniert, ABER leider benötigt es sehr lange für diesen Vorgang. Die Tabelle hat ungefähr 400 Zeilen.
Option Explicit
Sub Transfer_Fortschritt()
Dim strPath As String
Dim Aktuell As String
Dim MasterSh As Workbook
Dim findAk As Range
Dim FS As Range
Dim maxCount As Long
Dim AkCount As Long
strPath = ActiveWorkbook.Path
If Right(strPath, 1) "\" Then strPath = strPath & "\"
Do
Aktuell = Dir(strPath & "\*.xlsx")
Loop Until Aktuell ActiveWorkbook.Name
If Aktuell = "" Then Exit Sub
Set MasterSh = ActiveWorkbook
maxCount = Worksheets("Master").Cells(Rows.Count, 1).End(xlUp).Row
Workbooks.Open Filename:=strPath & Aktuell
AkCount = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For Each FS In ActiveWorkbook.Worksheets(1).Range("A4:A" & AkCount)
Set findAk = MasterSh.Worksheets("Master").Columns(1).Find(FS.Value)
If Not findAk Is Nothing Then
findAk.Offset(0, 17).Value = FS.Offset(0, 11).Value
findAk.Offset(0, 18).Value = FS.Offset(0, 12).Value
Else
maxCount = maxCount + 1
MsgBox FS.Offset(0, 0).Value & " " & FS.Offset(0, 11).Value
MasterSh.Worksheets("Master").Cells(maxCount, 1).Value = FS.Offset(0, 0).Value
MasterSh.Worksheets("Master").Cells(maxCount, 18).Value = FS.Offset(0, 11).Value
MasterSh.Worksheets("Master").Cells(maxCount, 19).Value = FS.Offset(0, 12).Value
End If
Next
Workbooks(Aktuell).Close SaveChanges:=False
End Sub
Meine Bitte an euch Experten: Kann man dieses Makro irgendwie modifizieren bzw. anders schreiben., damit der Vorgang schneller abläuft?
Vielen Dank euch!