Aktarma yapmak

[mest3651]

Merhaba. Yapmak istediğim dosyada açıkladım. Şimdiden teşekkürler.

 

[Muzaffer Ali]

Merhaba.

Sub Aktar()
    Dim Bak As Long
    Dim Bul As Range
    Dim Alan As Range
    Dim Bulunamayan As Boolean
    With Worksheets("Sayfa1")
        For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
            Set Bul = .Range("B:B").Find(what:=Cells(Bak, "A"), lookat:=xlWhole)
            If Bul Is Nothing Then
                Cells(Bak, "A").Interior.Color = 255
                Bulunamayan = True
            Else
                For Each Alan In .Range("F" & Bul.Row & ":K" & Bul.Row)
                    If Alan.Value = "" Then
                        
                        .Cells(Bul.Row, Alan.Column).Value = Cells(Bak, "C").Value
                        .Cells(Bul.Row + 1, Alan.Column).Value = Cells(Bak, "D").Value
                        
                        Exit For
                    End If
                Next
            End If
        Next
    End With
    If Bulunamayan Then MsgBox "Bulunamayan T.C. noları kımızı renk ile işaretlendi."
End Sub