• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Cift Isimleri Bulma

senuyurken

senuyurken

Katılım
20 Nisan 2008
Mesajlar
185
Excel Vers. ve Dili
Office 2021 TR
Sicil Nosuna Gore Arayip Iki Kez Avans Alan Kisileri Sayfa 2ye Avanslari Toplayarak Listelemesi Mumkunmu Acaba


Tesekkur Ederim

Ornek Dosya Ektedir
 
Merhaba,

Aşağıdaki kodları bir butona bağlayıp çalıştırabilirsiniz. Bir deneyiniz bakalım. Aman uyurken işlem yapmayınız, böyle çifter çifter avans verebilirsiniz :)


Kod: 
Sub AvansBul()
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A3:C65536").ClearContents
Dim i, sn, Var, SonSat As Integer
sn = 2
SonSat = s1.[A65536].End(3).Row
For i = 3 To SonSat
    Var = Application.WorksheetFunction.CountIf(s1.Range("A3:A" & SonSat), Cells(i, "A"))
    If Var > 1 Then
        Set Bul = s2.Columns(1).Find(s1.Cells(i, "A"))
        If Bul Is Nothing Then
            sn = sn + 1
            s2.Cells(sn, "A") = s1.Cells(i, "A")
            s2.Cells(sn, "B") = s1.Cells(i, "B")
            s2.Cells(sn, "C") = s1.Cells(i, "C")
        Else
            s2.Cells(Bul.Row, "C") = s2.Cells(Bul.Row, "C") + s1.Cells(i, "C")
        End If
    End If
Next i
MsgBox "İşlem Tamamdır"
Application.ScreenUpdating = True
End Sub
 
Necdet Yeşertener' Alıntı:
Merhaba,

Aşağıdaki kodları bir butona bağlayıp çalıştırabilirsiniz. Bir deneyiniz bakalım. Aman uyurken işlem yapmayınız, böyle çifter çifter avans verebilirsiniz :)


Kod: 
Sub AvansBul()
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A3:C65536").ClearContents
Dim i, sn, Var, SonSat As Integer
sn = 2
SonSat = s1.[A65536].End(3).Row
For i = 3 To SonSat
    Var = Application.WorksheetFunction.CountIf(s1.Range("A3:A" & SonSat), Cells(i, "A"))
    If Var > 1 Then
        Set Bul = s2.Columns(1).Find(s1.Cells(i, "A"))
        If Bul Is Nothing Then
            sn = sn + 1
            s2.Cells(sn, "A") = s1.Cells(i, "A")
            s2.Cells(sn, "B") = s1.Cells(i, "B")
            s2.Cells(sn, "C") = s1.Cells(i, "C")
        Else
            s2.Cells(Bul.Row, "C") = s2.Cells(Bul.Row, "C") + s1.Cells(i, "C")
        End If
    End If
Next i
MsgBox "İşlem Tamamdır"
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...



ILGIN ICIN TESEKKUR EDERIM... CALISTIGIM FIRMADA FIREWALL KULLANILDIGINDAN ZIPLI DOSYALARI DOWNLOAD YAPAMIYORUZ.. MUMKUNSE NORMAL OLARAK EKLESENIZ INDIRSEM... BUTON DAHA HIC ANLAMIYORUM... FORMUL GIRILEREK YAPILABILIRMIYIM.. EXCELDE COK COK YENIYIM...


TESEKKUR EDERIM SELAMETLE
 
Merhaba,

Fonksiyonlarla da yapılabilir fakat beni hem aşar hem sıkıntıya sokar.
Bir arkadaşımız mutlaka fonksiyonlara yapılmış çözümü sunacaktır size.
 
Necdet Yeşertener' Alıntı:
Merhaba,

Aşağıdaki kodları bir butona bağlayıp çalıştırabilirsiniz. Bir deneyiniz bakalım. Aman uyurken işlem yapmayınız, böyle çifter çifter avans verebilirsiniz :)


Kod: 
Sub AvansBul()
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A3:C65536").ClearContents
Dim i, sn, Var, SonSat As Integer
sn = 2
SonSat = s1.[A65536].End(3).Row
For i = 3 To SonSat
    Var = Application.WorksheetFunction.CountIf(s1.Range("A3:A" & SonSat), Cells(i, "A"))
    If Var > 1 Then
        Set Bul = s2.Columns(1).Find(s1.Cells(i, "A"))
        If Bul Is Nothing Then
            sn = sn + 1
            s2.Cells(sn, "A") = s1.Cells(i, "A")
            s2.Cells(sn, "B") = s1.Cells(i, "B")
            s2.Cells(sn, "C") = s1.Cells(i, "C")
        Else
            s2.Cells(Bul.Row, "C") = s2.Cells(Bul.Row, "C") + s1.Cells(i, "C")
        End If
    End If
Next i
MsgBox "İşlem Tamamdır"
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...


VALLAHA NASIL OLDU ISE BIR BUTON YAPTIM SIMDI... MAKRO OLARAK KAYDETTIM DEDIGINIZ GIBI.... AMA DUGMEYE BASTIGIMDA ISLEM TAMAMDIR YAZISI CIKIYOR FAKAT SAYFA 2 DE HIC BIRSEY LISTELEMIYOR....


TESEKKUR EDERIMMMM
 
Necdet Yeşertener... BU NE HIZ NE ZAMAN CEVAP YAZDINN... ORNEK DOSYAYI INDIRDIM VE TAM ISTEDIGIM GIBI OLMUS....

ALLAH RAZI OLSUN ELLERINE SAGLIK......

SAOLASINNN
 
eee Baktım ki Ankara'lısınız torpil geçeyim dedim :)
güle güle kullanınız.
 
Necdet Yeşertener' Alıntı:
eee Baktım ki Ankara'lısınız torpil geçeyim dedim :)
güle güle kullanınız.
Genişletmek için tıkla ...

Necdet Kardes cok saol yardikmlarin icin...


karde bir sorum daha olacakk...

senin yapmis oldugun ornek dosyayi tekrar ekledim... Aacaba sayfa 1 deki tabloda tum kayitlari sayfa ikiye tekrar listeleyebilirmiyiz. Cift kayitlarin toplamini alarak. Yani sayfa 1 deki tum liste olacak ayni zamanda sayfa bir deki cift kayit sayfa 2 de tutarlari toplanmis olarak tek isim olarak cikacak....


Tesekkur ederim ..




selametle...
ANKARA...:)
 
Merhaba,

Kodlardaki fazlalıkları atınca istediğiniz olur.

Kod: 
Sub AvansBul()
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A3:C65536").ClearContents
Dim i, sn, Var, SonSat As Integer
sn = 2
SonSat = s1.[A65536].End(3).Row
For i = 3 To SonSat
    Set Bul = s2.Columns(1).Find(s1.Cells(i, "A"))
    If Bul Is Nothing Then
        sn = sn + 1
        s2.Cells(sn, "A") = s1.Cells(i, "A")
        s2.Cells(sn, "B") = s1.Cells(i, "B")
        s2.Cells(sn, "C") = s1.Cells(i, "C")
    Else
        s2.Cells(Bul.Row, "C") = s2.Cells(Bul.Row, "C") + s1.Cells(i, "C")
    End If
Next i
s2.Columns("C:C").NumberFormat = "#,##0.00"
MsgBox "İşlem Tamamdır"
Application.ScreenUpdating = True
End Sub
 
Son düzenleme:
Necdet Yeşertener' Alıntı:
Merhaba,

Kodlardaki fazlalıkları atınca istediğiniz olur.

Kod: 
Sub AvansBul()
Application.ScreenUpdating = False
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A3:C65536").ClearContents
Dim i, sn, Var, SonSat As Integer
sn = 2
SonSat = s1.[A65536].End(3).Row
For i = 3 To SonSat
    Set Bul = s2.Columns(1).Find(s1.Cells(i, "A"))
    If Bul Is Nothing Then
        sn = sn + 1
        s2.Cells(sn, "A") = s1.Cells(i, "A")
        s2.Cells(sn, "B") = s1.Cells(i, "B")
        s2.Cells(sn, "C") = s1.Cells(i, "C")
    Else
        s2.Cells(Bul.Row, "C") = s2.Cells(Bul.Row, "C") + s1.Cells(i, "C")
    End If
Next i
s2.Columns("C:C").NumberFormat = "#,##0.00"
MsgBox "İşlem Tamamdır"
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...


necdet bey tesekkur ederim. Mumkunse diosyayi excel dosyasi ekleyebilirmisiniz. zipli dosyalari inderemiyorum... Tesekkur ederim...
 
Merhaba,

9. mesajdan dosyayı indirebilirsiniz.
 
Merhaba,

Alternatif olarak Fonksiyonlarla hazırlanmış dosta ektedir.



.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst