Yan yana aktarma

[Ahmet Sami]

Arkadaşlar Sizden istediğim yardım, buradaki bilgileri seçtikten sonra TERMALVERİ sayfasında ki isimlerinin karşısında bulunan ilgili tarih bölümüne TAKSİT in aktarılması yani hangi ismi ve tarihi seçersem o isim ve tarih karşılığına aktarması aynı isim ve aynı tarihe iki defa aktarım yapılmayacak teşekkür ederim.

 

[Necdet]

Merhaba,
Aşağıdaki kodları TERMAL sayfasının kod bölümüne kopyalayıp deneyiniz.
Umarım doğru anlamışımdır.

Bilgileri girdikten sonra herhangi bir hücreyi ÇİFT TIKLARSANIZ veriler aktarılır.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim c   As Range, _
        d   As Range

    Set c = Sayfa2.Range("B:B").Find(Range("D6"), LookIn:=xlValues, LookAt:=xlWhole)
    If c Is Nothing Then
        MsgBox Range("D6") & " KİŞİSİ BULUNAMADI...."
        Exit Sub
    End If
    
    Set d = Sayfa2.Range("2:2").Find(Range("D8"), LookIn:=xlValues, LookAt:=xlWhole)
    If d Is Nothing Then
        MsgBox Range("D8") & " YILINI BULUNAMADIM...."
        Exit Sub
    End If
    
    Sayfa2.Range("C" & c.Row) = Range("D7")
    Sayfa2.Range("D" & c.Row) = Range("D8")
    Sayfa2.Cells(c.Row, d.Column) = Range("D9")
    
    MsgBox "Veriler Aktarılmıştır.....", vbInformation, "AKTARMA .... "
    
End Sub

 

[Muzaffer Ali]

Ben farklı anladım. Alternatif olsun.
Veri sayfasında olmayan bir isim girerseniz yeni kayıt olarak ekler.

Aşağıdaki kodu bir modüle kopyalayıp, butona atayınız.

Sub Aktar()
    Dim Bul_Isim As Range, Bul_Yil As Range
    Dim syfVeri As Worksheet
    Dim Satir As Long
    Dim TermaliAldigiTarih As String
   
    Set syfVeri = Worksheets("TERMALVERİ")
   
    With Sayfa1
        If .ComboBox1.Value = "" Then
            MsgBox "Lütfen önce 'ADI SOYADI' seçiniz."
            Exit Sub
        ElseIf .ComboBox2.Value = "" Then
            MsgBox "Lütfen önce 'TERMAL ODA SAYISI' seçiniz."
            Exit Sub
        ElseIf .ComboBox3.Value = "" Then
            MsgBox "Lütfen önce 'TARİH' seçiniz."
            Exit Sub
        ElseIf .Range("D9").Value = "" Then
            MsgBox "Lütfen önce 'TAKSİT TUTARI' seçiniz."
            Exit Sub
        End If
        Set Bul_Isim = syfVeri.Range("B:B").Find(what:=.ComboBox1.Text, lookat:=xlWhole)
        Set Bul_Yil = syfVeri.Rows(2).Find(what:=.ComboBox3.Text, lookat:=xlWhole)
       
        If Bul_Yil Is Nothing Then
            MsgBox .ComboBox3.Text & " yılı veri sayfasında bulunamıyor. Lütfen kontrol ederek yeniden deneyiniz."
            Exit Sub
        End If
        If Bul_Isim Is Nothing Then
            Satir = syfVeri.Cells(Rows.Count, "A").End(xlUp).Row + 1
            syfVeri.Cells(Satir, "D") = InputBox("Bu isim listede bulunmuyor yeni kayıt edilecektir. Lütfen 'TERMALİ ALDIĞI TARİHİ' giriniz.", , Year(Now))
        Else
            Satir = Bul_Isim.Row
        End If
        If syfVeri.Cells(Satir, Bul_Yil.Column) <> "" Then
            If MsgBox("Bu isim ve tarihte taksit girişi zaten yapılmış, bilgileri değiştirmek ister misiniz?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
        End If
       
        syfVeri.Cells(Satir, "A") = Satir - 2
        syfVeri.Cells(Satir, "B") = .ComboBox1.Text
        syfVeri.Cells(Satir, "C") = .ComboBox2.Text
        syfVeri.Cells(Satir, Bul_Yil.Column) = .Range("D9").Value
    End With
    MsgBox "Aktarım gerçekleştirildi."
End Sub

 

[Ahmet Sami]

Çok teşekkür ederim. Emeğinize sağlık sağolun.

 

[Ahmet Sami]

Özür dilerim bir yardım daha rica edeceğim ama. Birde döküm almak için TERMAL SAYFASINDAN DÖKÜM AL butonuna tıklayınca DÖKÜM sayfasında ki gibi liste oluşturulup kimler ödemişse onun listesini verebilir mi.

 

[Muzaffer Ali]

Deneyiniz.

Sub Dokum_Al()
    Dim Bul_Yil As Range
    Dim Satir As Long
    Dim Tarih As String
    Dim syfVeri As Worksheet
    
    Tarih = Worksheets("TERMAL").ComboBox3.Text
    
    Set syfVeri = Worksheets("TERMALVERİ")
    Set Bul_Yil = syfVeri.Rows(2).Find(what:=Tarih, lookat:=xlWhole)
    
    If Bul_Yil Is Nothing Then
        MsgBox Tarih & " yılı veri sayfasında bulunamıyor. Lütfen kontrol ederek yeniden deneyiniz."
        Exit Sub
    End If
    
    With Sheets("DÖKÜM")
        If .Range("A3") <> "" Then .Range("A3:E" & Sheets("DÖKÜM").Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
    End With
    
    syfVeri.Range("E2:AR12").AutoFilter Field:=Bul_Yil.Column - 4, Criteria1:="<>"
    Satir = syfVeri.Cells(Rows.Count, "A").End(xlUp).Row
    syfVeri.Range("A3:D" & Satir).Copy Sheets("DÖKÜM").Range("A3")
    syfVeri.Range("E2").AutoFilter
    MsgBox "Tamamlandı."
End Sub

 

[Ahmet Sami]

Üstadım tam anlatamadım galiba Combobox3 ten hangi tarihi seçersem döküm al sayfasına getirmesi gerekiyor. Ekte ki gibi olması gerekiyor.

 

[Ahmet Sami]

Ayrıca TERMAL harici olan TERMALVERİ ve DÖKÜM sayfalarımı gizliyorum üstadım yani gizli sayfa durumunda aktarması gerekiyor.

 

[Muzaffer Ali]

Tekrar denedim kodlar tam da sizin istediğiniz şeyi yapıyor.
Sayfaların gizli olması bir şey değiştirmez.
Dosya ekte.
Sizin istediğinizden farklı olarak ne oluyor?

 

[Ahmet Sami]

Muzaffer hocam ÖDEME D sütununa tarih değil hangi tarihi girersem o tarihe ve kişilere ait ödemeler gelmesi lazım

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Sub Dokum_Al()
    Dim Bul_Yil As Range
    Dim Satir As Long
    Dim Tarih As String
    Dim syfVeri As Worksheet
    
    Tarih = Worksheets("TERMAL").ComboBox3.Text
    
    Set syfVeri = Worksheets("TERMALVERİ")
    Set Bul_Yil = syfVeri.Rows(2).Find(what:=Tarih, lookat:=xlWhole)
    
    If Bul_Yil Is Nothing Then
        MsgBox Tarih & " yılı veri sayfasında bulunamıyor. Lütfen kontrol ederek yeniden deneyiniz."
        Exit Sub
    End If
    
    With Sheets("DÖKÜM")
        If .Range("A3") <> "" Then .Range("A3:E" & Sheets("DÖKÜM").Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
    End With
    
    syfVeri.Range("E2:AR12").AutoFilter Field:=Bul_Yil.Column - 4, Criteria1:="<>"
    Satir = syfVeri.Cells(Rows.Count, "A").End(xlUp).Row
    syfVeri.Range("A3:C" & Satir).Copy Sheets("DÖKÜM").Range("A3")
    syfVeri.Range(Cells(3, Bul_Yil.Column).Address & ":" & Cells(Satir, Bul_Yil.Column).Address).Copy Sheets("DÖKÜM").Range("D3")
    
    syfVeri.Range("E2").AutoFilter
    MsgBox "Tamamlandı."
End Sub

 

[Ahmet Sami]

Muzaffer hocam çok teşekkür ederim. Tam istediğim gibi oldu emeğinize sağlık.

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.