Otomatik zimmet kaydı oluşturmak

[Sonarex33]

Merhaba üstadlar. ödeme emri tarihi ve posta nereye kriterlerini seçerek ilçemiz içi ve il dışı postalarını sicil-takip no- adı soyadı- posta adresi hücrelerini örnekteki gibi otomatik doldurarak posta listesi oluşturmak istiyorum. 01.01.2022.tarihli ilçemiz olanı listele dediğimde zimmet raporunu oluşturmasını ve döküm almasını istiyorum. Yardımcı olursanız çok memnun olurum.

 

[Sonarex33]

Başlık sorum günceldir.

 

[dEdE]

Dosyanız ektedir.

 

[Sonarex33]

Dosyanız ektedir.

Sayın dEdE teşekkür ederim tam istediğim gibi olmuş. yalnız tarih kısmındaki veri doğrulama yeni kayıt girdiğimde getirmiyor. Elle de giremiyorum

 

[dEdE]

....yalnız tarih kısmındaki veri doğrulama yeni kayıt girdiğimde getirmiyor. Elle de giremiyorum

Sayfa1'in kodunu silip aşağıdaki kodu yapıştırarak deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
ss = Sheets("Sayfa1").Cells(Rows.Count, "H").End(3).Row
If Intersect(Target, Range("H3:H" & ss + 1)) Is Nothing Then Exit Sub
    Dim Dizi()
    ReDim Dizi(ss)
    
    myArr = Sheets("Sayfa1").Range("H3:H" & ss)
    Set myList = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(myArr)
       If Not myList.Contains(myArr(i, 1)) Then myList.Add myArr(i, 1)
    Next
    myList.Sort
 
    For k = 0 To myList.Count - 1
        Dizi(p) = myList(k)
        p = p + 1
    Next k
    
    t = Join(Dizi, ",")
    Sheets("Sayfa1").Range("H1").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=t
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "DİKKAT"
        .ErrorTitle = "DİKKAT"
        .InputMessage = "Listeden seçim yapınız. Elle veri girmeyiniz."
        .ErrorMessage = "Listeden seçim yapınız. Elle veri girmeyiniz."
        .ShowInput = True
        .ShowError = True
    End With
End Sub

 

[Sonarex33]

Sayfa1'in kodunu silip aşağıdaki kodu yapıştırarak deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
ss = Sheets("Sayfa1").Cells(Rows.Count, "H").End(3).Row
If Intersect(Target, Range("H3:H" & ss + 1)) Is Nothing Then Exit Sub
    Dim Dizi()
    ReDim Dizi(ss)
   
    myArr = Sheets("Sayfa1").Range("H3:H" & ss)
    Set myList = CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(myArr)
       If Not myList.Contains(myArr(i, 1)) Then myList.Add myArr(i, 1)
    Next
    myList.Sort

    For k = 0 To myList.Count - 1
        Dizi(p) = myList(k)
        p = p + 1
    Next k
   
    t = Join(Dizi, ",")
    Sheets("Sayfa1").Range("H1").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=t
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = "DİKKAT"
        .ErrorTitle = "DİKKAT"
        .InputMessage = "Listeden seçim yapınız. Elle veri girmeyiniz."
        .ErrorMessage = "Listeden seçim yapınız. Elle veri girmeyiniz."
        .ShowInput = True
        .ShowError = True
    End With
End Sub

Sayın Dede oldu. Teşekkür ederim