Düğme İle Veri Aktarma ve Günceleme

[hilmi0707]

Selamlar. Bir düğme yardımı ile bir hücredeki veriyi öncül veriye bağlı olarak başka bir hücreye aktarma ve günceleme ile iligili bir çalışmamız var.
Yardımlarınız için çok teşekkür ederim.

Örnek Dosya

 

[DoğanD]

Merhaba,

Aşağıdaki kodu kullanabilirsiniz. Çalıştırmadan önce E sütununda yazdığınız açıklamayı silin lütfen. Çünkü her çalışmasında E sütunundaki kitap sayısına göre işlem yapıyor. Bununla birlikte, aynı kitap tekrar aktarılırsa yine büyük olan yazacak şekilde bir kurgu bu. Farklı bir talebiniz varsa iletebilirsiniz.

Sub aktar()
Dim i, y As Integer
For i = 2 To Range("e" & Rows.Count).End(xlUp).Row
If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 5)) = 0 Then Cells(Range("a" & Rows.Count).End(xlUp).Row + 1, 1) = Cells(i, 5)
y = WorksheetFunction.Match(Cells(i, 5), Range("A:A"), 0)
If Cells(y, 2) < Cells(i, 6) Then Cells(y, 2) = Cells(i, 6)
Next i
End Sub

 

[Necdet]

Merhaba,
Alternatif olsun, Doğan arkadaşımız çözümü sunmuş ama kod boşuna gitmesin.

Sub Deneme()

Dim c   As Range, _
    i   As Integer

For i = 2 To Cells(Rows.Count, "E").End(3).Row
    
    Set c = Range("A:A").Find(Cells(i, "E"), LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        If Cells(i, "F") > c.Offset(0, 1) Then c.Offset(0, 1) = Cells(i, "f")
    Else
        Cells(i, "G") = "BULUNAMADI..."
    End If
    
Next i

End Sub

 

[hilmi0707]

Merhaba,

Aşağıdaki kodu kullanabilirsiniz. Çalıştırmadan önce E sütununda yazdığınız açıklamayı silin lütfen. Çünkü her çalışmasında E sütunundaki kitap sayısına göre işlem yapıyor. Bununla birlikte, aynı kitap tekrar aktarılırsa yine büyük olan yazacak şekilde bir kurgu bu. Farklı bir talebiniz varsa iletebilirsiniz.

Sub aktar()
Dim i, y As Integer
For i = 2 To Range("e" & Rows.Count).End(xlUp).Row
If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 5)) = 0 Then Cells(Range("a" & Rows.Count).End(xlUp).Row + 1, 1) = Cells(i, 5)
y = WorksheetFunction.Match(Cells(i, 5), Range("A:A"), 0)
If Cells(y, 2) < Cells(i, 6) Then Cells(y, 2) = Cells(i, 6)
Next i
End Sub

Harika oldu elinize sağlık.
Fakat biz gerçek dosya üzerinde değil de sizi yormamak adına sade bir örnek üzerinden dosya hazırlamıştık. Sadece hücre isimlerini değiştirerek uyarlama yaparız diye düşünmüştük ama beceremedik.

Gerçek dosyayı da paylaşıyorum sizinle.
Burada Kitap İsimleri PROGRAM adlı sayfada D sütununda yazılan gri dolgulu alanda.
SON SAYFA bilgisi ise yine aynı sayfada K sütununda gri alanda.
4 Ayrı periyotta çalışma programımız var.
Bu bilgileri
KİTAP LİSTESİ adlı sayfadaki D sütununa aktaracağız. Uyarlama yapabilirseniz çok memnun oluruz.
Çok teşekkür ederiz.

Tam Dosya

 

[DoğanD]

Merhaba,

Kontrol eder misiniz?

Sub aktar()
Dim i, y As Integer
For i = 2 To Sayfa3.Range("d" & Rows.Count).End(xlUp).Row
If WorksheetFunction.CountIf(Sayfa1.Range("b:b"), Sayfa3.Cells(i, 4)) = 0 Or Sayfa3.Cells(i, 4) = "" Then GoTo atla
y = WorksheetFunction.Match(Sayfa3.Cells(i, 4), Sayfa1.Range("b:b"), 0)
If Sayfa1.Cells(y, 4) < Sayfa3.Cells(i, 11) Then Sayfa1.Cells(y, 4) = Sayfa3.Cells(i, 11)
atla:
Next i
End Sub

 

[hilmi0707]

Merhaba,

Kontrol eder misiniz?

Sub aktar()
Dim i, y As Integer
For i = 2 To Sayfa3.Range("d" & Rows.Count).End(xlUp).Row
If WorksheetFunction.CountIf(Sayfa1.Range("b:b"), Sayfa3.Cells(i, 4)) = 0 Or Sayfa3.Cells(i, 4) = "" Then GoTo atla
y = WorksheetFunction.Match(Sayfa3.Cells(i, 4), Sayfa1.Range("b:b"), 0)
If Sayfa1.Cells(y, 4) < Sayfa3.Cells(i, 11) Then Sayfa1.Cells(y, 4) = Sayfa3.Cells(i, 11)
atla:
Next i
End Sub

Elinize sağlık tekrar çok güzel oldu. Allah razı olsun.
Sadece yeni girilen veri daha önceki veriden küçükse güncelleme yapmıyor. Örneğin Türkçe Mutlu kitabında bitiş sayfasını 45 olarak planlamışız ve veri aktarmışız. Daha sonra bu plan gerçekleşmemiş ve 40 olarak tekrar planlamışız. Bu durumda güncelleme yapmıyor.