I need to copy data from sheet 1 to sheet 2. Sheet 1 has randomized experimental data in it. In sheet 3 are tables for the different variants and rating dates of the experiment. There is a third sheet which has the experimental plan in it and the plots are differentiated through color and values “A”, “B” etc. (the construction is identical to sheet 1). I´m trying to set a filter for each variant (red + “A”, green + “B” etc.) to filter the cells from each variant in sheet 3 and than copy the values which have the same cell adresses out of sheet 1 in sheet 2.

I never worked with Excel VBA and all the codes I tried to do with ChatGPT are not working.

Sub FilterAndCopy()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim filterRange As Range
Dim cell As Range
Dim targetRow As Long
Dim colorCriteria As Long
Dim letterCriteria As String
Dim lastRow As Long
Dim lastCol As Long

' Set worksheets
Set ws1 = ThisWorkbook.Sheets("Sheet1") ' experimental plan
Set ws2 = ThisWorkbook.Sheets("Sheet2") ' rating date 1
Set ws3 = ThisWorkbook.Sheets("Sheet3") ' tables

' Define the filter criteria
colorCriteria = RGB(255, 51, 0)
letterCriteria = "A"

' Find the last row and column in Sheet1
lastRow = 30 ' Set the last filled row in Sheet1
lastCol = ws1.Cells(1, "CU").End(xlToLeft).Column ' Set the last filled column in Sheet1

' Define the range to filter on Sheet1
Set filterRange = ws1.Range(ws1.Cells(2, 1), ws1.Cells(lastRow, lastCol)) ' Adjust the range as per your data, excluding header row

' Initialize target row on Sheet3
targetRow = 10 ' Start from row 10 in column K

' Loop through the range in Sheet1 and check for criteria
For Each cell In filterRange
    If cell.Interior.Color = colorCriteria And cell.Value = letterCriteria Then
        ' Get the corresponding value from Sheet2 and copy it to Sheet3
        Dim valueAddress As String
        valueAddress = cell.Address
        Dim correspondingValue As Variant
        On Error Resume Next
        correspondingValue = ws2.Range(valueAddress).Value
        On Error GoTo 0
        If Not IsError(correspondingValue) Then
            ws3.Cells(targetRow, "K").Value = correspondingValue
            targetRow = targetRow + 1
        End If
    End If
Next cell

MsgBox "Data has been copied successfully!"

End Sub