Soru Bulunacak değerlere ilave talebi.

[reosman]

Saygıdeğer üstadlarım.

Bir türlü beceremediğim,
Ekte sunduğum resimdede görükeceği üzere İz ve İz Arşiv sayfalarında
bulunan tarih kısımlarınında bulunan kısmına ilave edilmesini talep ediyorum.

 

[reosman]

Yardımlarınızı rica ediyorum.

 

[reosman]

Arama yaptığım form Userform1 bu formdaki listbox'a İz ve İz Arşiv sayfalarındaki Tarih kısımları F sütunları ilave edilecek.

 

[reosman]

Günaydınlar, Merhabalar, Hayırlı Günler

 

[reosman]

Üstadlarım yardımlarınızı rica ediyorum.

 

[reosman]

Üstadlarım saygılarımla.

 

[reosman]

Rica ediyorum bir yardım

 

[reosman]

üstadlar lütfen rica ediyorum bir el atın

 

[reosman]

Sorum günceldir.

 

[reosman]

Güncel.

 

[muratboz06]

dosya.tc sitesine dosyanızı ve ekran görüntüsünü ekleyerek paylaşınız.
Bakalım.

 

[reosman]

Murat bey ilginize teşekkür ederim. Yukarıda hem ekran görüntüsü hem de dosya var yinede yükleyelim.

https://s5.dosya.tc/server4/ps2ulm/ADYS_8.0__BS_.xlsm.html

https://s5.dosya.tc/server4/ps2ulm/Adsiz.png.html

 

[reosman]

Murat bey yükledim size zahmet olacak.

 

[reosman]

Bir türlü başaramadım.

 

[reosman]

Private Sub CommandButton1_Click()
Dim k As Range, ilk_adres As String, A As Long
Dim i  As Long, syf As String, myarr()
ListBox1.Clear
If TextBox1.Value = "" Then
    MsgBox "Lütfen Sicil Numarasını Giriniz !!!", 16, "Dikkat"
    End If
    If TextBox1.Value = "" Then Exit Sub
        ReDim myarr(1 To 3, 1 To 1)
For i = 1 To ComboBox1.ListCount - 1
    If ComboBox1.Value <> "HEPSİ" Then
        syf = ComboBox1.Value
        Else
        syf = ComboBox1.Column(0, i)
    End If
    Set k = Sheets(syf).[D:D].Find(TextBox1.Value, , xlValues, xlWhole, , 1)
    If Not k Is Nothing Then
        ilk_adres = k.Address
        Do
        A = A + 1
        ReDim Preserve myarr(1 To 3, 1 To A)
        myarr(1, A) = syf
        myarr(2, A) = k.Address(False, False)
        myarr(3, A) = k.Value
        Set k = Sheets(syf).[D:D].FindNext(k)
        Loop While ilk_adres <> k.Address And Not k Is Nothing
    End If
    If ComboBox1.Value <> "HEPSİ" Then Exit For
    Next i
    Set k = Nothing
    Label3.Caption = "Kriterlere Uyan " & A & " Adet Kayıt Bulundu..!!"
    If A > 0 Then
        ListBox1.Column = myarr
        Erase myarr
        MsgBox "Aranan Kayıtlar Listelendi!!", vbOKOnly + vbInformation, "ARA-BUL"
    End If
    If A < 1 Then MsgBox "Aradığınız Veri Bulunamadı..!!", vbCritical, "DİKKAT"
    TextBox1.Value = ""
    TextBox1.SetFocus
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub Textbox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Then
    Call CommandButton1_Click
End If
Call TextBox1.SetFocus
End Sub
Private Sub ListBox1_Click()
If ListBox1.ListCount < 1 Then Exit Sub
Sheets(ListBox1.Column(0, ListBox1.ListIndex)).Select
Range(ListBox1.Column(1)).Select
End Sub
Private Sub TextBox1_Change()
    If Not (IsNumeric(TextBox1)) Then SendKeys "{bs}"
End Sub
Private Sub UserForm_Initialize()
Dim syf As Worksheet
ComboBox1.AddItem "HEPSİ"
For Each syf In Worksheets
    ComboBox1.AddItem syf.Name
Next
ComboBox1.ListIndex = 0
ListBox1.ColumnCount = 3
ListBox1.ColumnWidths = "100;80;80"
TextBox1.SetFocus
End Sub
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger _
, ByVal Shift As Integer)
    If KeyCode = 27 Then Unload Me
End Sub

 

[YUSUF44]

Userform'in kodlarını aşağıdakiyle değiştirip deneyiniz. Tabi formun boyutlarında ve yerleşiminde de düzeltme yapmanız gerekecek, onları halledersiniz:

Private Sub CommandButton1_Click()
Dim k As Range, ilk_adres As String, A As Long
Dim i  As Long, syf As String, myarr()
ListBox1.Clear
If TextBox1.Value = "" Then
    MsgBox "Lütfen Sicil Numarasını Giriniz !!!", 16, "Dikkat"
    End If
    If TextBox1.Value = "" Then Exit Sub
        ReDim myarr(1 To 4, 1 To 1)
For i = 1 To ComboBox1.ListCount - 1
    If ComboBox1.Value <> "HEPSİ" Then
        syf = ComboBox1.Value
        Else
        syf = ComboBox1.Column(0, i)
    End If
    Set k = Sheets(syf).[D:D].Find(TextBox1.Value, , xlValues, xlWhole, , 2)
    If Not k Is Nothing Then
        ilk_adres = k.Address
        Do
        A = A + 1
        ReDim Preserve myarr(1 To 4, 1 To A)
        myarr(1, A) = syf
        myarr(2, A) = k.Address(False, False)
        myarr(3, A) = k.Value
        If syf = "İz" Or syf = "İz Arşiv" Then
            myarr(4, A) = k.Offset(0, 2)
        End If
              
        Set k = Sheets(syf).[D:D].FindNext(k)
        Loop While ilk_adres <> k.Address And Not k Is Nothing
    End If
    If ComboBox1.Value <> "HEPSİ" Then Exit For
    Next i
    Set k = Nothing
    Label3.Caption = "Kriterlere Uyan " & A & " Adet Kayıt Bulundu..!!"
    If A > 0 Then
        ListBox1.Column = myarr
        Erase myarr
        MsgBox "Aranan Kayıtlar Listelendi!!", vbOKOnly + vbInformation, "ARA-BUL"
    End If
    If A < 1 Then MsgBox "Aradığınız Veri Bulunamadı..!!", vbCritical, "DİKKAT"
    TextBox1.Value = ""
    TextBox1.SetFocus
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub Textbox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Then
    Call CommandButton1_Click
End If
Call TextBox1.SetFocus
End Sub
Private Sub ListBox1_Click()
If ListBox1.ListCount < 1 Then Exit Sub
Sheets(ListBox1.Column(0, ListBox1.ListIndex)).Select
Range(ListBox1.Column(1)).Select
End Sub
Private Sub TextBox1_Change()
    If Not (IsNumeric(TextBox1)) Then SendKeys "{bs}"
End Sub
Private Sub UserForm_Initialize()
Dim syf As Worksheet
ComboBox1.AddItem "HEPSİ"
For Each syf In Worksheets
    ComboBox1.AddItem syf.Name
Next
ComboBox1.ListIndex = 0
ListBox1.ColumnCount = 4
ListBox1.ColumnWidths = "100;80;80;80"
TextBox1.SetFocus
End Sub
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger _
, ByVal Shift As Integer)
    If KeyCode = 27 Then Unload Me
End Sub

 

[muratboz06]

Private Sub CommandButton1_Click()
Dim k As Range, ilk_adres As String, A As Long
Dim i  As Long, syf As String, myarr()
ListBox1.Clear
If TextBox1.Value = "" Then
    MsgBox "Lütfen Sicil Numarasını Giriniz !!!", 16, "Dikkat"
    End If
    If TextBox1.Value = "" Then Exit Sub
        ReDim myarr(1 To 4, 1 To 1)
For i = 1 To ComboBox1.ListCount - 1
    If ComboBox1.Value <> "HEPSİ" Then
        syf = ComboBox1.Value
        Else
        syf = ComboBox1.Column(0, i)
    End If
    Set k = Sheets(syf).[D:D].Find(TextBox1.Value, , xlValues, xlWhole, , 2)
 
    If Not k Is Nothing Then
        ilk_adres = k.Address
        Do
        A = A + 1
        ReDim Preserve myarr(1 To 4, 1 To A)
        myarr(1, A) = syf
        myarr(2, A) = k.Address(False, False)
        myarr(3, A) = k.Value
        myarr(4, A) = k.Offset(0, 2).Value
          
        Set k = Sheets(syf).[D:D].FindNext(k)
        Loop While ilk_adres <> k.Address And Not k Is Nothing
    End If
    
    If ComboBox1.Value <> "HEPSİ" Then Exit For
    Next i
    ' MsgBox k.Offset(0, 2).Value
    Set k = Nothing
    Label3.Caption = "Kriterlere Uyan " & A & " Adet Kayıt Bulundu..!!"
    If A > 0 Then
        ListBox1.Column = myarr
        Erase myarr
        MsgBox "Aranan Kayıtlar Listelendi!!", vbOKOnly + vbInformation, "ARA-BUL"
    End If
    If A < 1 Then MsgBox "Aradığınız Veri Bulunamadı..!!", vbCritical, "DİKKAT"
    TextBox1.Value = ""
    TextBox1.SetFocus
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub Textbox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Then
    Call CommandButton1_Click
End If
Call TextBox1.SetFocus
End Sub
Private Sub ListBox1_Click()
If ListBox1.ListCount < 1 Then Exit Sub
Sheets(ListBox1.Column(0, ListBox1.ListIndex)).Select
Range(ListBox1.Column(1)).Select
End Sub

Private Sub UserForm_Initialize()
Dim syf As Worksheet
ComboBox1.AddItem "HEPSİ"
For Each syf In Worksheets
    ComboBox1.AddItem syf.Name
Next
ComboBox1.ListIndex = 0
ListBox1.ColumnCount = 4
ListBox1.ColumnWidths = "50;50;50;50"
TextBox1.SetFocus
End Sub
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger _
, ByVal Shift As Integer)
    If KeyCode = 27 Then Unload Me
End Sub

ListBox1.ColumnWidths = "50;50;50;50" satırını kendinize göre güncellersiniz.

 

[reosman]

RABBİM sizlerden razı olsun. Deneyip bilgi vereceğim. Saygılarımla. Çok çok teşekkür ederim.

 

[reosman]

Üstadlarım harikasınız sadece bulunduğunda çıkan tarih 6/22/2021 şeklinde
bunu 22/06/2021 veya 22.06.2021 şeklinde düzeltebilirmiyiz ?

 

[YUSUF44]

Üstadlarım harikasınız sadece bulunduğunda çıkan tarih 6/22/2021 şeklinde
bunu 22/06/2021 veya 22.06.2021 şeklinde düzeltebilirmiyiz ?

İlgili satırı aşağıdakiyle değiştirin:

myarr(4, A) = Format(k.Offset(0, 2), "dd/mm/yyyy")