Karşılıksız çek-günü gelmemiş çek

[a.c.uysak]

Herkese selam,

konuyu çok araştırdım hazır yapılmış programlar da buldum fakat bulduğum programlara benzer zaten şirkette de mevcut. Benim istediğim biraz da ha özet bir tablo. O yüzden bu başlığı açtım.

Elimde çek dosyası mevcut. Bu dosyadan bu günün tarihine göre geriye dönük tarama yaparak ödenmemiş çekleri yazdırmasını istiyorum.

Ayrıca o müşteriye ait gelecek çeklerin de listesini yanına yazdırmak istiyorum.

Böylece bir müşterinin mevcut riskini ve gelecek riskini birlikte görmek istiyorum.

Yardımcı olursanız çok memnun olurum.

Hepinize kolay gelsin.

 

[a.c.uysak]

Pardon dosyayı eklemeyi unutmuşum.

 

[a.c.uysak]

Yardımcı olabilecek biri var mı?

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub CekLitesi()
 
    Dim c As Range, Adr As Variant, Sc As Worksheet
    Dim sat As Long, i As Long, son As Long
 
    Application.ScreenUpdating = False
    
    Set Sc = Sheets("ÇEK LİSTESİ")
    Sheets("KARŞILIKSIZ ÇEK LİSTESİ").Select
    Range("A2:E" & Rows.Count).Clear
    sat = 2

    With Sc.Range("E:E")
      Set c = .Find("ÖDEMEDİ", , xlValues, xlWhole)
        If Not c Is Nothing Then
          Adr = c.Address
            Do
              If Sc.Cells(c.Row, "A") < Date Then
                Sc.Range("A" & c.Row, "D" & c.Row).Copy Cells(sat, "A")
                sat = sat + 1
              End If
            Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
    
    son = sat - 2
    sat = sat + 2
    With Sc.Range("B:B")
     For i = 2 To son
      Set c = .Find(Cells(i, "B"), , xlValues, xlWhole)
        If Not c Is Nothing Then
          Adr = c.Address
            Do
              If Sc.Cells(c.Row, "A") >= Date Then
                Sc.Range("A" & c.Row, "C" & c.Row).Copy Cells(sat, "A")
                Cells(sat, "E") = Sc.Cells(c.Row, "D")
                sat = sat + 1
              End If
            Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
     Next i
    End With
    
    Set c = Nothing: Set Sc = Nothing
    
    Application.ScreenUpdating = True
 
End Sub

.

 

[a.c.uysak]

ÖMER BEY,

Öncelikle gerçekten çok teşekkür ederim. Forumdan hiç cevap gelmeyecek sandım. inanılmaz işime yarayacak fakat bir şey sormak istiyorum, Macro hakkında hiç bir bilgim yok sadece kopyalayıp yapıştırıp çalıştırdım Gönderdiğim dosya bilgi gizliliği açısından kendi oluşturduğum örnek dosya.aynı kodu başka dosyaya da bu şekilde uygulasam aynı işi görür mü?

Emeğinize sağlık.

 

[a.c.uysak]

Ayrıca, kodda sanırım ufak bir sorun var bazı verileri iki kere yazdırmış acaba nereden kaynaklanıyor olabilir?
Rica etsem , Zahmet olmazsa tekrar bir göz atabilir misiniz?

 

[Ömer]

bazı verileri iki kere yazdırmış

Düzeltildi. #4 numaralı mesajı yeniden deneyin.

Gönderdiğim dosya bilgi gizliliği açısından kendi oluşturduğum örnek dosya.aynı kodu başka dosyaya da bu şekilde uygulasam aynı işi görür mü?

Eğer tablo düzenin aynı ise çalışır. Fakat sayfa ismi yada satır sütunların yeri değişik ise bu kısımları tekrardan düzenlemek gerekir.

.

 

[a.c.uysak]

ömer bey,

biraz geç cevap verebildim kusura bakmayın.

Emeğinize sağlık çok teşekkür ederim. Istediğim gibi olmuş.

Keyifli çalışmalar