Guten Tag und Servus liebe Herbers Excel-Forum Gemeinde
Ich versuche seit ca. 2 Wochen, zusammen mit ChatGPT ein, (in meinen Augen) relativ leichte Aufgabenstellung hinzubekommen
und bin langsam echt am verzweifeln ;)
Es geht darum aus einer kleinen Liste (5 Werte maximal) immer ein Wert nach dem anderen in eine Ziel Zelle zu kopieren.
Dabei soll nachgesehen werden falls in der Zielzelle bspw. der dritte Wert der Liste steht, sollte mit dem nächsten Wert also
dem vierten Wert der Liste weitergemacht bzw. kopiert werden. Dabei sollte jeder Wert für ca. 30 Sekunden stehen bleiben und mit dem nächsten
Wert der Liste ersetzt werden. Dabei gibt es noch 2 Dinge zu beachten neben der Spalte mit den Werten gibt es noch eine Spalte mit entweder einer 1 oder 0,
es sollten nur Werte kopiert werden die nebendran eine 1 haben und nicht die mit einer Null. Falls in der Liste nur einen einzigen Wert mit einer 1 in der benachbarten Spalte
gibt, sollte nicht kopiert werden und der Wert solange beibehalten werden bis es einen zweiten Wert mit einer benachbarten 1 gibt. Zusätzlich sollte nachdem der letzte Werte der Liste kopiert wurde, der Code wieder von Vorne beginnen und auch im besten fall 24/7 laufen und nicht stoppen.
Okay wenn ich so darüber nachdenke ist es vielleicht doch nicht so einfach wie ich angenommen hatte ;)
Als Referenz sende ich euch mal den kompletten VBA Code den ich bis heute mit ChatGPT hinbekommen habe,
leider läuft der Code nicht und es werden immer wieder Errors oder Fehler generiert-
ich bedanke mich bereits jetzt bei euch für eure Hilfe und wünsche euch einen super Tag!!!
Option Explicit
#If VBA7 Then
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub CopyNextValue()
Dim currentValue As String
Dim nextValue As String
Dim rangeA As Range
Dim rangeB As Range
Dim cellA As Range
Dim cellB As Range
Dim copiedIndex As Long
Dim lastCopiedValue As String
Dim foundCell As Range ' Add this line to declare the foundCell variable
' Set the range to CC68:CC72
Set rangeA = Range("CC68:CC72")
' Set the range to CD68:CD72
Set rangeB = Range("CD68:CD72")
' Get the current value of DA4
currentValue = Range("DA4").Value
' Find the cell containing the current value
Set foundCell = rangeA.Find(What:=currentValue, LookIn:=xlValues, LookAt:=xlWhole)
' Get the index of the last copied value
If Not foundCell Is Nothing Then
copiedIndex = foundCell.Row - rangeA.Cells(1).Row + 1
Else
copiedIndex = 0
End If
' Set the last copied value
lastCopiedValue = currentValue
' Loop through the range starting from the next index
For Each cellA In rangeA.Cells(copiedIndex + 1).Resize(rangeA.Cells.Count - copiedIndex)
Set cellB = rangeB.Cells(cellA.Row - rangeA.Cells(1).Row + 1)
' Check if the cell in column CC is non-empty, has a 1 in column CD,
' and not equal to the last copied value
If cellA.Value > "" And cellB.Value = 1 And cellA.Value > lastCopiedValue Then
nextValue = cellA.Value
Exit For
End If
Next cellA
' If no next value found, start from the beginning
If nextValue = "" Then
For Each cellA In rangeA.Cells
Set cellB = rangeB.Cells(cellA.Row - rangeA.Cells(1).Row + 1)
' Check if the cell in column CC is non-empty, has a 1 in column CD,
' and not equal to the last copied value
If cellA.Value > "" And cellB.Value = 1 And cellA.Value > lastCopiedValue Then
nextValue = cellA.Value
Exit For
End If
Next cellA
End If
' Copy the next value to DA4
If nextValue > "" Then
Application.EnableEvents = False ' Disable events to prevent the OnTime event from triggering
Range("DA4").Value = nextValue
SendKeys "{ESC}"
Application.EnableEvents = True ' Re-enable events
End If
' Schedule the macro to run again after 15 seconds
Application.OnTime Now + TimeValue("00:00:15"), "CopyNextValue"
' Delay for 15 seconds before checking for the next
Sleep 15000 ' Sleep for 15 seconds (15000 milliseconds)
End Sub