Soru Bulunacak değerlere ilave talebi.

Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
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.
 

Ekli dosyalar

Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Yardımlarınızı rica ediyorum.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
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.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Günaydınlar, Merhabalar, Hayırlı Günler
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Üstadlarım yardımlarınızı rica ediyorum.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Üstadlarım saygılarımla.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Rica ediyorum bir yardım
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
üstadlar lütfen rica ediyorum bir el atın
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Sorum günceldir.
 

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
568
Excel Vers. ve Dili
Office365 TR
dosya.tc sitesine dosyanızı ve ekran görüntüsünü ekleyerek paylaşınız.
Bakalım.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Murat bey yükledim size zahmet olacak.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Bir türlü başaramadım.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Kod:
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

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
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:

PHP:
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

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
568
Excel Vers. ve Dili
Office365 TR
Kod:
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.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
RABBİM sizlerden razı olsun. Deneyip bilgi vereceğim. Saygılarımla. Çok çok teşekkür ederim.
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Ü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

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Ü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")
 
Üst