Belirtilen hesap kodları getirilmesi hk.

[1903emre34@gmail.com]

Merhaba,

Ana kod bölümüne ; 740,191,320 hesap kodları yazdığımda muavin sayfasında aynı fiş numarasında ise arama sayfasına getirilmesi için kodlarda nasıl değişiklik yapabiliriz?

Örneğin; hesap kodları yazdığımda (740,191,320) mahsup fişi numarası 1 ve 2 numaralı olan yevmiye kayıtları getiriyor, ama ben fiş numarası "2" getirilmesini istiyorum çünkü fiş numarasında belirtilen hesap kodların dışında hesap yok.

 

[Asri]

Merhaba,

Ana kod bölümüne ; 740,191,320 hesap kodları yazdığımda muavin sayfasında aynı fiş numarasında ise arama sayfasına getirilmesi için kodlarda nasıl değişiklik yapabiliriz?

Örneğin; hesap kodları yazdığımda (740,191,320) mahsup fişi numarası 1 ve 2 numaralı olan yevmiye kayıtları getiriyor, ama ben fiş numarası "2" getirilmesini istiyorum çünkü fiş numarasında belirtilen hesap kodların dışında hesap yok.

Kırmızı alanlarda ekleme ve değişiklik yapıldı.
Kontrol ediniz.

Sub BARAN_OZEL_FILTRE()
Set m = Sheets("MUAVİN")
Set a = Sheets("ARAMA")
Set wf = Application.WorksheetFunction '***Kıısa AD TANIMLAMALARI
mson = m.Cells(Rows.Count, 1).End(3).Row '*** MUAVİN sayfası sonsatır
brn = WorksheetFunction.Match(a.[B1], a.Range("B2:B" & Rows.Count), 0) - 1 '***KRİTER ALANINDAKİ SATIR SAYISI

If a.Cells(Rows.Count, 2).End(3).Row > brn + 2 Then '*** VARSA ÖNCEKİ İŞLEMDEN KALAN VERİLER TEMİZLENECEK
   [COLOR=red] 'a.[F1] = ""[/COLOR]
    a.Range("B" & brn + 3 & ":I" & Rows.Count).Clear
End If

If wf.CountIf(a.Range("B2:B" & brn), "<>") < 2 Then Exit Sub '*** KRİTER ALANININDA 2'DEN AZ KOD YAZILIYSA İŞLEM YAPMADAN ÇIKILACAK.
bas = Timer '**** İŞLEM SÜRESİNİ ÖLÇMEK İÇİN SAYACI BAŞLAT
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual '*** HIZ AÇISINDAN EKRAN DONDURULDU, HESAPLAMA DEVRE DIŞI

m.Range("A1:H" & mson).AutoFilter '**** MUAVİN SAYFASINDA, VARSA FİLTRE KALDIRILIYOR, YOKSA FİLTRE UYGULANMIŞ OLUYOR
sut = 9 '*** KOD GEÇİCİ OLARAK 9'UNCU SÜTUNDAN İTİBARENKİ SÜTULARI KULLANACAK
m.Activate '*** MUAVİN SAYFASI AKTİFLEŞTİRİLDİ

m.Columns("J:" & Replace(Cells(1, sut + brn).Address(0, 0), 1, "")).Insert Shift:=xlToRight '*** KOD'UN KULLANACAĞI SÜTUN SAYISI KADAR J SÜTUNUNDAN İTİBAREN ARAYA SÜTUN EKLENİYOR
                                        '*** MAKSAT J VE DEVAMI SÜTUNLARDA VERİ VARSA GEÇİCİ OLARAK SAĞA DOĞRU KAYDIRMAK.
For sat = 2 To brn '*** 2'NCİ SATIRDAN İTİBAREN ARAMA SAYFASI B SÜTUNUNDAKİ HESAP KODLARI OKUNACAK
    If a.Cells(sat, 2) <> "" Then  '*** SATIRDA HESAP KODU YAZILIYSA İŞLEME DEVAM
    adet = adet + 1  '*** 2'NCİ SATIRDAN İTİBAREN KAÇ SATIRDA VEDİ OLDUĞU (BU AYNI ZAMANDA EKLENECEK FİŞNOLARI SÜTUNLARININ SAYISI OLACAK)
        m.Range("A1:H" & mson).AutoFilter Field:=1, Criteria1:="" & a.Cells(sat, 2) & ""  '*** MUAVİN SAYFASI A SÜTUNUNA HESAP KODUNA GÖRE TEK TEK FİLTRE UYGULANIYOR
        sut = sut + 1 '*** FİŞ NUMARALARININ YAZILACAĞI SÜTUN NUMARASI 10'DAN İTİBAREN 1 ARTIRILACAK
            If m.Cells(Rows.Count, 1).End(3).Row > 1 Then
                m.Range("E2:E" & mson).SpecialCells(xlCellTypeVisible).Copy m.Cells(2, sut) '*** J SÜTUNUNDAN İTİBAREN FİLTRE SONUCUNDA KALAN E SÜTUNU DEĞERLERİ YAZILIYOR
                m.Range("A1:H" & mson).AutoFilter Field:=1  '*** A SÜTUNUNDAKİ FİLTRE KALDILIYOR
                m.Range(m.Cells(1, sut), m.Cells(mson, sut)).RemoveDuplicates Columns:=1, Header:=xlNo  '*** FİŞ NUMARALIRININ YAZILDIĞI SÜTUNDA YİNELENENLER KALDIRILIYOR
            End If
    End If
Next  '*** FOR SATIRINDAN BURAYA KADARKİ İŞLEMLER YAZILAN HESAP KODU SAYISI KADAR TEKRARLANAACAK

m.Range("A1:H" & mson).AutoFilter Field:=1  '*** A SÜTUNUNDAKİ FİLTRE KALDILIYOR
sonsut = 9 + brn  '*** EN SONDA GELİŞMİŞ FİLTRE UYGULANACAK SÜTUN NUMARASI
m.Cells(1, sonsut + 1) = "FİŞ NO"  '*** EN SONDAKİ SÜTUNA BAŞLIK YAZILDI
sutsonsat = m.Cells(Rows.Count, 10).End(3).Row  '*** AŞAĞIDAKİ DÖNGÜ; 2'DEN, SÜTUNUNDAKİ DOLU SATIR SAYISINA KADAR UYGULANACAK

For sat1 = 2 To sutsonsat  '*** EN SONDAKİ SÜTUNA BAŞLIK YAZILDI
    If wf.CountIf(m.Range(m.Cells(2, 10), m.Cells(mson, 9 + brn)), m.Cells(sat1, 10)) = adet Then  '*** J SÜTUNUNDAKİ DEĞER J VE DEVAMI SÜTUNLARDA HESAP KODU ADETİ KADAR VAR MI?
        say = say + 1  '*** VARSA, SAY DEĞİŞKENİ ARAMA SAYFASI F1 HÜCRESİNE YAZILACAK DEĞERİ SAYIYOR
            m.Cells(m.Cells(Rows.Count, 9 + brn + 1).End(3).Row + 1, 9 + brn + 1) = m.Cells(sat1, 10)  '*** EN SONDAKİ SÜTUNA, BULUNAN VE DAHA SONRA GELİŞMİŞ FİLTREDE KRİTER OLARAK KULLANILACAK FİŞ NUMARASI YAZILIYOR
            m.Cells(sat1, 10).ClearContents  '*** ADET KONTROLÜNDEN GEÇMİŞ J SÜTUNUNDAKİ FİŞ NO SİLİNİYOR Kİ; MÜKERRER KAYIT OLMASIN.
    End If
Next

[COLOR=red]m.Range("R2:R" & Rows.Count).Clear
m.Range("R2").Value = a.Range("F1")[/COLOR]
m.Range("A1:H" & mson).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
m.Range(m.Cells(1, sonsut + 1), m.Cells(m.Cells(Rows.Count, sonsut + 1).End(3).Row, sonsut + 1)), Unique:=False  '*** GELİŞMİŞ FİLTRE KULLANILARAK SON SÜTUNA YAZILAN FİŞ NUMARALARINA GÖRE E SÜTUNU FİLTRELENDİ (AŞAĞIDA KOPYALANACAK)
m.Columns("J:" & Replace(Cells(1, sut + brn + 1).Address(0, 0), 1, "")).Delete Shift:=xlToLeft 'J SÜTUNUNDAN İTİBAREN EKLENEN GEÇİCİ SÜTUNLAR SİLİNDİ VE SAYFA ESKİ HALİNE GETİRİLDİ.
a.Activate  '*** ARAMA SAYFASINA GEÇİLDİ

If say = 0 Then  '*** SAY DEĞİŞKENİ 0 İSE (YANİ ORTAK FİŞ NO YOKSA)
    m.Range("A1:H1").AutoFilter  '*** MUAVİN SAYFASINDAKİ FİLTREYİ KALDIR
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic   '*** EKRAN DONDURMA VE HESAPLAMA DURDURMAYI İPTAL ET.
    MsgBox "Yazılan ANA HESAP KODLARInın tümünü birden içeren FİŞ YOK." & vbLf & vbLf & _
            "İşlem süresi : " & Format((Timer - bas), "0.000"), vbInformation, " "  '*** ORTAK FİŞ NO OLMADIĞINI VE İŞLEM SÜRESİNİ BİLDİR.
    Exit Sub
Else  '*** SAY DEĞİŞKENİ 0'DAN BÜYÜKSE
    m.Range("A1").CurrentRegion.Copy a.Cells(brn + 2, 2) '*** YERİNDE GELİŞMİŞ FİLTRE UYGULANAN ALANI ARAMA SAYFASINA KOPYALA
    m.Range("A1:H1").AutoFilter  '*** MUAVİN SAYFASINDAKİ FİLTREYİ KALDIR
    [COLOR=red]'a.[F1] = say  '*** ORTAK FİŞ ADETİNİ F1 HÜCRESİNE YAZ[/COLOR]
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic  '*** EKRAN DONDURMA VE HESAPLAMA DURDURMAYI İPTAL ET.
    MsgBox "İşlem Tamamlandı..." & vbLf & "B2:B" & brn & " alanına yazılan HESAP KODLARININ TÜMÜNÜ BİRDEN İÇEREN" & vbLf & _
            a.[F1] & "  ADET FİŞ içeriği aşağıya listelendi." & vbLf & vbLf & _
            "İşlem süresi : " & Format((Timer - bas), "0.000"), vbInformation, " "   '*** LİSTELEMENİN YAPILDIĞINI  VE İŞLEM SÜRESİNİ BİLDİR.
End If
End Sub