AW: Die 6 Makros existieren und funktionieren
06.07.2025 14:57:47
Christian
Hallo Ralf,
du liegst leider zumindest teilweise danaben.
Du hast zumindest in sofern recht, dass die Makros nicht selbst programmiert wurden, das war bestimmt 10 Std. Arbeit mit Chatgpt bis alles ins kleinste Detail gepasst hat, wie es soll, sowie wirklich alle so optimiert war, was Chatgpt eingefallen ist, was man optimieren könnte und es auch danach noch lief.
Das sind riesige Makros, ich glaube das größte hat in Word eingefügt 22 Seiten, dazu noch 7 weitere Module, die aus den Makros ausgelagert sind, damit diese nicht noch länger werden. 90% davon sind Abläufe, die man genauso gut auch mit Klicken oder Copy + Paste oder per Formel erledigen könnte, das weiß ich, mir ging es bei der Aktion einfach darum, die vielen Dinge die ich wöchentlich mit neuen Daten mache automatisiert zu verarbeiten, anstatt jedes mal wöchentlich alles von Hand.
Aber jetzt zu dem eigentlichen Anliegen.
Allein das erste Makro braucht 3-4 Stunden, weil es sehr viele Internetseiten öffnet und Daten ausliest. Ich wollte einfach nur einen Überblick haben, wie lange die 6 Makros jeweils brauchen, um den Tag an dem die neuen Daten kommen und ich damit die ganze Mappe update zeitlich besser planen kann.
Und da die Zahl der Daten wöchentlich steigt, wird zwangsweise auch die Verarbeitung der Daten immer länger brauchen, sodass ich vorhabe mir irgendwann nochmal einen erneuten Überblick zu verschaffen wie lange es dauert, deshalb die Wahl mit oder ohne Timer ausführen.
Aber weil du eins der Makros haben wolltest, hier das fünfte und kleinste:
Sub fünftesMakro()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
On Error GoTo Fehler
Call UpdateUmwandeln
Dim wsP As Worksheet, ws300 As Worksheet, wsUpd As Worksheet, wsKop As Worksheet
Set wsP = ThisWorkbook.Sheets("Punkte")
Set ws300 = ThisWorkbook.Sheets("300")
Set wsUpd = ThisWorkbook.Sheets("Update")
Set wsKop = ThisWorkbook.Sheets("Kopie")
Dim lastP As Long, last3 As Long, lastU As Long, lastKop As Long
lastP = wsP.Cells(wsP.Rows.count, "A").End(xlUp).Row
last3 = ws300.Cells(ws300.Rows.count, "A").End(xlUp).Row
lastU = wsUpd.Cells(wsUpd.Rows.count, "A").End(xlUp).Row
lastKop = wsKop.Cells(wsKop.Rows.count, "A").End(xlUp).Row
Dim r300_A As String, r300_C As String, r300_D As String
Dim rUpd_C As String, rUpd_A As String
Dim rKop_A As String, rKop_F As String
r300_A = "'300'!$A$1:$A$" & last3
r300_C = "'300'!$C$1:$C$" & last3
r300_D = "'300'!$D$1:$D$" & last3
rUpd_C = "Update!$C$1:$C$" & lastU
rUpd_A = "Update!$A$1:$A$" & lastU
rKop_A = "Kopie!$A$1:$A$" & lastKop
rKop_F = "Kopie!$F$1:$F$" & lastKop
wsP.Range("H1:H" & lastP).FormulaLocal = "=XVERWEIS(A1;" & rUpd_C & ";" & rUpd_A & ";"""";0;1)"
wsP.Range("B1:B" & lastP).FormulaLocal = "=XVERWEIS(A1;" & r300_A & ";" & r300_C & ";"""";0;1)"
wsP.Range("C1:C" & lastP).FormulaLocal = "=XVERWEIS(A1;" & r300_A & ";" & r300_D & ";"""";0;1)"
wsP.Range("D1:D" & lastP).FormulaLocal = "=WENN(RANG.GLEICH(C1;$C$1:$C$" & lastP & ";0)31;RANG.GLEICH(C1;$C$1:$C$" & lastP & ";0);"""")"
wsP.Range("E1:E" & lastP).FormulaLocal = "=301*ANZAHL(H1:BG1)-SUMME(H1:BG1)"
wsP.Range("F1:F" & lastP).FormulaLocal = "=RANG.GLEICH(E1;$E$1:$E$" & lastP & ";0)"
wsP.Range("G1:G" & lastP).FormulaLocal = "=MIN(H1:BG1)"
wsP.Range("B1:H" & lastP).Value2 = wsP.Range("B1:H" & lastP).Value2
With ThisWorkbook.Sheets("Hilfe").Range("F2")
.FormulaLocal = _
"=""https://www.imdb.com/search/name/?birth_date=""&TEXT(EDATUM(HEUTE()-WOCHENTAG(HEUTE();2)+2;-360);""JJJJ-MM-TT"")&"",""&TEXT(EDATUM(HEUTE()-WOCHENTAG(HEUTE();1)+2;-216);""JJJJ-MM-TT"")&""&gender=female&adult=include&count=250"""
.Value2 = .Value2
End With
' Sortieren ohne Header
wsP.Range("A1:BG" & lastP).Sort Key1:=wsP.Range("E1:E" & lastP), Order1:=xlDescending, Header:=xlNo
' Schriftfarbe komplett schwarz setzen
wsP.Range("A1:BH" & lastP).Font.Color = vbBlack
' Zeilen mit D > 0 rot färben
Dim i As Long
For i = 1 To lastP
If IsNumeric(wsP.Cells(i, "D").Value) Then
If wsP.Cells(i, "D").Value > 0 Then
wsP.Range(wsP.Cells(i, "A"), wsP.Cells(i, "BG")).Font.Color = vbRed
End If
End If
Next i
wsP.Columns("A").Insert Shift:=xlToRight
lastP = wsP.Cells(wsP.Rows.count, "B").End(xlUp).Row
wsP.Range("A1:A" & lastP).FormulaLocal = "=WENN(ODER(E1>"""";I131);XVERWEIS(B1;" & rKop_A & ";" & rKop_F & ";301;0;1)-G1;"""")"
wsP.Range("A1:A" & lastP).Value2 = wsP.Range("A1:A" & lastP).Value2
wsP.Range("A1:A" & lastRow).AutoFilter Field:=1, Criteria1:=">"
CleanUp:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
Exit Sub
Fehler:
MsgBox "Fehler: " & Err.Description, vbExclamation
Resume CleanUp
End Sub