Hesap Koduna ve Cariye göre fiş getirme

[igultekin2000]

iyi günler; fiş numarasına göre fişle ilgili detayları FIS_DETAY sayfasına sorunsuz getiriyorum. Konuyu biraz detaylandırmak gerekiyor. Firma ünvanı ve Hesap Kodu seçtiğimde o hesap kodunun ve firmanın isminin geçtiği fişlerin FIS_DETAY sayfasına getirilmesi gibi bir işlem yapmak istiyorum. Bilgim mevcut kodlarda oynama yaparak kendime uyarlamak ama buna uygun örnek bulamadım. Yardımcı olabilecek arkadaşlara teşekkür ederim.

 

[igultekin2000]

konuyu daha pratik hale getirerek 2018 çalışma sayfasının K sütununa listelenmesini istediğim Yevmiye numaralarını dizi formülü ile listeledim. Ad tanımlaması yaparak FIS_DTY çalışma sayfasının B2 hücresine veri doğrulama olarak tanımladım. B2 hücresini açarak gelmesini istediğim verileri seçerek tek tek gelmesini sağlayabiliyorum. daha pratik olması için veri doğrulamada olan yevmiye numaralarının tamamını tek tıklama ile getirmek için kullandığım kodda ne gibi düzenleme gerekir. Teşekkürler.

Sub hspno_getir()
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Dim s As Worksheet
Dim a As Long, b As Long, c As Long
Dim MM
Set s = Sheets("FIS_DTY")
Sheets("FIS_DTY").Range("A4:I65536").ClearContents
MM = 4
For a = 1 To Sheets.Count
    If s.Cells(2, "A") Like Sheets(a).Name Then
        For b = 2 To Sheets(a).Cells(65536, "A").End(3).Row
        If s.Cells(2, "B") = Sheets(a).Cells(b, "B") Then
            For c = 1 To 9
            s.Cells(MM, c) = Sheets(a).Cells(b, c)
            Next
            MM = MM + 1
        End If
        Next
    End If
Next
Sheets("FIS_DTY").Range("A4:I" & Range("I65536").End(3).Row).Font.Name = "Calibri"
Sheets("FIS_DTY").Select
Sheets("FIS_DTY").Range("A4:I" & Range("I65656").End(3).Row).Font.Size = 11 'yazı tipi boyutu
Sheets("FIS_DTY").Select
Sheets("FIS_DTY").Range("D4:G" & Range("G65656").End(3).Row).NumberFormat = "#,##0.00"
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

 

[turist]

Dosyanız eklidir.

 

[askm]

Alternatif

Sub ASKM()
Dim s As Worksheet
Set s = Sheets("2018")
Dim son As Long
Range("A4:I10000").ClearContents
son = s.Range("A" & Rows.Count).End(3).Row
For i = 3 To son
    If s.Cells(i, "K") <> "" Then
        Range("B2").Value = s.Cells(i, "K")
        Call hspno_getir
    End If
Next i
End Sub

Sub hspno_getir()
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Dim s As Worksheet
Dim a As Long, b As Long, c As Long
Set s = Sheets("FIS_DTY")
'Sheets("FIS_DTY").Range("A4:I65536").ClearContents
mm = Range("A" & Rows.Count).End(3).Row + 1
For a = 1 To Sheets.Count
    If s.Cells(2, "A") Like Sheets(a).Name Then
        For b = 2 To Sheets(a).Cells(65536, "A").End(3).Row
        If s.Cells(2, "B") = Sheets(a).Cells(b, "B") Then
            For c = 1 To 9
            s.Cells(mm, c) = Sheets(a).Cells(b, c)
            Next
            mm = mm + 1
        End If
        Next
    End If
Next
Sheets("FIS_DTY").Range("A4:I" & Range("I65536").End(3).Row).Font.Name = "Calibri"
Sheets("FIS_DTY").Select
Sheets("FIS_DTY").Range("A4:I" & Range("I65656").End(3).Row).Font.Size = 11 'yazı tipi boyutu
Sheets("FIS_DTY").Select
Sheets("FIS_DTY").Range("D4:G" & Range("G65656").End(3).Row).NumberFormat = "#,##0.00"
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

 

[Ömer BARAN]

Merhaba.

Ben de hazıramıştım ekleyeyim bari (belge içerisindeki açıklamalara bakınız)

 

[igultekin2000]

Merhaba.

Ben de hazıramıştım ekleyeyim bari (belge içerisindeki açıklamalara bakınız)

çok teşekkür ederim, çok pratik ve kullanışlı olmuş. emeğinize sağlık.

 

[igultekin2000]

Dosyanız eklidir.

Teşekkür ederim, emeğinize sağlık.

 

[igultekin2000]

Sub ASKM() Dim s As Worksheet Set s = Sheets("2018") Dim son As Long Range("A4:I10000").ClearContents son = s.Range("A" & Rows.Count).End(3).Row For i = 3 To son If s.Cells(i, "K") <> "" Then Range("B2").Value = s.Cells(i, "K") Call hspno_getir End If Next i End Sub

bu kod başka işlemlerde de kullanabileceğim bir kod, teşekkür ederim, emeğinize sağlık.