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

 

[mest3651]

çok teşekkür ederim.

 

[mest3651]

yazdığımız t.c , tarih ve miktarları silme butonu ekleyebilirmiyiz.

 

[Muzaffer Ali]

Merhaba.
Sayfa2 A, C ve D sütunlarını temizleyen kod

Sub Temizle()
    Dim SonSatir As Long
    If MsgBox("Listeyi temizlemek istediğinizden emin misiniz?", vbQuestion + vbYesNo) = vbYes Then
        SonSatir = Cells(Rows.Count, "A").End(xlUp).Row
        Range("A2:A" & SonSatir & ",C2:D" & SonSatir).ClearContents
    End If
End Sub

Eğer B sütunu da temizlenecekse aşağıdaki kodu kullanın

Sub Temizle()
    Dim SonSatir As Long
    If MsgBox("Listeyi temizlemek istediğinizden emin misiniz?", vbQuestion + vbYesNo) = vbYes Then
        SonSatir = Cells(Rows.Count, "A").End(xlUp).Row
        Range("A2:D" & SonSatir).ClearContents
    End If
End Sub