• DİKKAT

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

Vadesi Geçmişleri Listeleme

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Merhabalar,

Ekteki dosyada vadesi geçenleri listelemek için ne yapmam gerek ? Yardımlarınız için şimdiden teşekkür ederim.
 

Ekli dosyalar

Sayın Dunya_
Yarım saat içinde cevap beklemişsiniz ama takdir edersiniz ki forumdaki tüm arkadaşların ilgilenmesi gereken işleri var ve demek ki bu zaman aralığında kimse vakit bulamamış.Yoksa bazen dakikalar içinde cevap veren arkadaşlar çıkıyor.Aşağıdaki kodlar sanırım istediğiniz gibi.Dener misiniz?

Kod: 
Sub listele()
yaz = 10
sıra = 1
For i = 4 To Sheets("Liste").Cells(65536, 2).End(xlUp).Row
If Sheets("Liste").Cells(i, 4) < Date Then
Sheets("Dağılım").Cells(yaz, 8) = sıra
Sheets("Dağılım").Cells(yaz, 9) = Sheets("Liste").Cells(i, 3)
Sheets("Dağılım").Cells(yaz, 10) = Sheets("Liste").Cells(i, 4)
Sheets("Dağılım").Cells(yaz, 11) = Sheets("Liste").Cells(i, 5)
Sheets("Dağılım").Cells(yaz, 12) = Sheets("Liste").Cells(i, 6)

sıra = sıra + 1
yaz = yaz + 1
End If
Next
End Sub
 
Sayın bedersu

Öncelikle zahmet ve uğraşınız için teşekkür ederim. Verdiğiniz kodu bendeki kodla nasıl birleştirebilirim ?

benim kodlar

Sub Emre()
Dim i As Integer
Application.ScreenUpdating = False
Range("A10:F20").ClearContents
Range("A26:F75").ClearContents
Range("H10:L20").ClearContents
Range("B26:L36").ClearContents
Range("H42:L75").ClearContents
a = 10: b = 26: c = 10: d = 26: e = 42
With Sayfa2
For i = 4 To .Range("B65536").End(3).Row
If .Cells(i, "G") Like "BO*" Then
.Cells(i, 2).Resize(, 5).Copy
Sayfa1.Cells(a, 2).PasteSpecial xlValue
a = a + 1
End If
If .Cells(i, "G") Like "Cİ*" Then
.Cells(i, 2).Resize(, 5).Copy
Sayfa1.Cells(b, 2).PasteSpecial xlValue
b = b + 1
End If

'
'


If .Cells(i, "G") Like "TA*" Then
.Cells(i, 2).Resize(, 5).Copy
Sayfa1.Cells(d, 8).PasteSpecial xlValue
d = d + 1
End If
If .Cells(i, "G") Like "PORT*" Then
.Cells(i, 2).Resize(, 5).Copy
Sayfa1.Cells(e, 8).PasteSpecial xlValue
e = e + 1
End If
Next i
End With
i = Empty
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox " ..::.. Liste Tamamlandı ..::.. ", vbInformation + vbMsgBoxRtlReading, Application.UserName
End Sub
 
Sn Dunya
bedersu nun vermiş olduğu kodları başka bir düğmeye ata olsun.
Gibi
 

Ekli dosyalar

bedersu' Alıntı:
Sayın Dunya_
Yarım saat içinde cevap beklemişsiniz ama takdir edersiniz ki forumdaki tüm arkadaşların ilgilenmesi gereken işleri var ve demek ki bu zaman aralığında kimse vakit bulamamış.Yoksa bazen dakikalar içinde cevap veren arkadaşlar çıkıyor.Aşağıdaki kodlar sanırım istediğiniz gibi.Dener misiniz?

Kod: 
Sub listele()
yaz = 10
sıra = 1
For i = 4 To Sheets("Liste").Cells(65536, 2).End(xlUp).Row
If Sheets("Liste").Cells(i, 4) < Date Then
Sheets("Dağılım").Cells(yaz, 8) = sıra
Sheets("Dağılım").Cells(yaz, 9) = Sheets("Liste").Cells(i, 3)
Sheets("Dağılım").Cells(yaz, 10) = Sheets("Liste").Cells(i, 4)
Sheets("Dağılım").Cells(yaz, 11) = Sheets("Liste").Cells(i, 5)
Sheets("Dağılım").Cells(yaz, 12) = Sheets("Liste").Cells(i, 6)

sıra = sıra + 1
yaz = yaz + 1
End If
Next
End Sub
Genişletmek için tıkla ...

Sayın bedersu,
Eklediğiniz kodda tarihi eskiden yeniye sıralamak için ne yapmak gerek ?
 
Sayın nane

Kodlar dosyaya ekli değil. Ben her iki kodu tek düğmeye eklemek istemiştim ama yapamadım. Ayrı düğmeye tanımladım.
 
Sayın Dunya_
Hayırlı bayramlar.Aşağıdaki kodlar dener misiniz? Kodlar birleştirilmiştir:

Kod: 
Sub Emre()
    Dim i As Integer
    Application.ScreenUpdating = False
    Range("A10:F20").ClearContents
    Range("A26:F75").ClearContents
    Range("H10:L20").ClearContents
    Range("B26:L36").ClearContents
    Range("H42:L75").ClearContents
    a = 10: b = 26: c = 10: d = 26: e = 42
    With Sayfa2
    For i = 4 To .Range("B65536").End(3).Row
        If .Cells(i, "G") Like "BO*" Then
            .Cells(i, 2).Resize(, 5).Copy
            Sayfa1.Cells(a, 2).PasteSpecial xlValue
            a = a + 1
        End If
        If .Cells(i, "G") Like "Cİ*" Then
            .Cells(i, 2).Resize(, 5).Copy
            Sayfa1.Cells(b, 2).PasteSpecial xlValue
            b = b + 1
        End If
     '  If .Cells(i, "G") Like "PORT*" Then
     '     .Cells(i, 2).Resize(, 5).Copy
     '     Sayfa1.Cells(c, 8).PasteSpecial xlValue
     '     c = c + 1
     '     End If
        If .Cells(i, "G") Like "TA*" Then
            .Cells(i, 2).Resize(, 5).Copy
            Sayfa1.Cells(d, 8).PasteSpecial xlValue
            d = d + 1
        End If
        If .Cells(i, "G") Like "PORT*" Then
            .Cells(i, 2).Resize(, 5).Copy
            Sayfa1.Cells(e, 8).PasteSpecial xlValue
            e = e + 1
        End If
    Next i
    End With
    i = Empty
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    

yaz = 10
sıra = 1
For i = 4 To Sheets("Liste").Cells(65536, 2).End(xlUp).Row
If Sheets("Liste").Cells(i, 4) < Date Then
Sheets("Dağılım").Cells(yaz, 8) = sıra
Sheets("Dağılım").Cells(yaz, 9) = Sheets("Liste").Cells(i, 3)
Sheets("Dağılım").Cells(yaz, 10) = Sheets("Liste").Cells(i, 4)
Sheets("Dağılım").Cells(yaz, 11) = Sheets("Liste").Cells(i, 5)
Sheets("Dağılım").Cells(yaz, 12) = Sheets("Liste").Cells(i, 6)

sıra = sıra + 1
yaz = yaz + 1
End If
Next
    With ActiveWorkbook.Worksheets("Dağılım").Sort
        .SetRange Range("I10:L19")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    
    
 MsgBox " ..::.. Liste Tamamlandı ..::.. ", vbInformation + vbMsgBoxRtlReading, Application.UserName
End Sub
 
Arkadaşlar sizden bir ricam olacak
Ekli dosyada çek/senet tablomda aynı tarihte olanları tarih bazında toplatmak için ne yapmam gerek.

Teşekkürler,
 

Ekli dosyalar

Ekli tabloda yan tarafta durum diye oluşturduğum tabloya gelmesi iyi olur.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst