igili kodu alttaki ile değiştirip deneyin.
Ayrıca bazı cells yazan yerlere aktif sayfanın ismini yazmalısınız eğer başka safadayken kod çalışırsa o aktif sayfada işlem yapar hata olur ama değilse gerek yok ben kod sayfa kodlarına eklemiştim bundan dolayı eklememiştim siz modül içine almışsınız.
Kod:
Sub Aktar()
Dim bul, bul2, ara As Range, say As Integer, i As Integer
say = 1: ReDim arr(1 To 1)
With ThisWorkbook.Worksheets("Kimya")
For i = 4 To 18
bul = Application.Match(Cells(i, "B").Value2, .Range("C:C"), 0)
If Not IsError(bul) Then
'içerik eklenirse burdan tekrar düzenle
For Each ara In .Range("I" & bul & ":BU" & bul)
ReDim Preserve arr(1 To say)
If Len(Trim(ara.Value)) > 0 Then
If Trim(Cells(3, say + 1).Value) = "" Then
bul2 = Application.Match(.Cells(2, ara.Column).Value2, arr, 0)
If Not IsError(bul2) Then
arr(say) = arr(bul2)
Else
arr(say) = .Cells(2, ara.Column).Value
say = say + 1
End If
End If
End If
Next
End If
Next
If say > 1 Then Cells(3, "G").Resize(1, say).Value = arr
End With
End Sub