Alttaki kod kullanılabilir.

Sub aktar()



Dim i As Integer, j As Byte, say As Integer

Dim syfveri As Worksheet

Set syfveri = Sayfa7



Dim syfistif As Worksheet

Set syfistif = Sayfa1



say = 2

syfistif.Range("A2" & Rows.Count).ClearContents

With syfveri

    For i = 10 To 89

        For j = 2 To 44 '44 ar sütun no

            If LCase(.Cells(9, j).Value) = "adet" And _

               Len(.Cells(i, j).Value) > 0 And .Cells(i, j).Interior.ColorIndex = 6 Then '6 demek sari renk

                syfistif.Cells(say, 1).Value = .Cells(5, "C").Value

                syfistif.Cells(say, 2).Value = .Cells(i, "A").Value

                syfistif.Cells(say, 3).Value = .Cells(8, j).Value

                syfistif.Cells(say, 4).Value = .Cells(i, j).Value

                say = say + 1

            End If

        Next

    Next

End With

MsgBox "islem tamam", vbInformation, "Aktrama"

Set syfveri = Nothing

Set syfistif = Nothing

End Sub