ARA-VBA

[uewhes]

Merhaba,
Excel görünümüm tahmini olarak aşağıdaki gibi olacaktır.
---A------------------B----C-----D----E (SATIRIN UZERİNDEKİ EXCEL HARFLERİNİ İFADE ETMEKTEDİR.)
Parça No/PDFNO---1-----2-----3----4
4321-----------------X
789 -----------------------X
654------------------------X----X

Amaç : Bir buton yardımı ile arama yapıp aratmış olduğum parça hangi satırda ise, o satırdaki x ile işaretİi sütun hangisi ise,o sütundaki PDF numarasını bana mesaj box olarak bilgi vermesini istiyorum.
Örnek : butona tıkladığımda arama yapacağım parça numarasını gireceğim örnek olarak 4321 sonrasında bana ilgili parça 1 numarada olduğu için, bana Parçayı "1" numaralı pdf de bulabilirsiniz mesajını verecek.
654 ü arattığımda ise aradığınız parça 2 ve 3 numaralı pdf bulabilirsiniz şeklinde.Yardımcı olabilirseniz sevinirim.

Maalesef dosya yükleyemiyorum. "-" ön izlemede düzgün gözüksün diye konuldu.

 

[AdemCan]

Merhaba, tablonuz resimdeki gibi olursa, paylaştığım kodları kullanabilirsiniz.

Option Base 1
Sub test()
no = Application.InputBox("Parça Numarasını Yazınız", "Parça Numarası Arama Ekranı")
If no = False Then Exit Sub
Set sh = Sayfa1
s = sh.Cells(Rows.Count, 1).End(3).Row
a = WorksheetFunction.CountIf(sh.Range("A2:A" & s), no)

If a >= 1 Then
    b = sh.Range("A:A").Find(no).Row
    r = WorksheetFunction.CountIf(sh.Range("B" & b & ":E" & b), "x")
    ReDim d(r)
    r = 1
        For Each h In sh.Range("B" & b & ":E" & b)
            If h.Value = "x" Then
                c = h.Column
                d(r) = sh.Cells(1, c)
                r = r + 1
            End If
        Next
    m = Join(d, " ve ")
    MsgBox no & " numaralı parçayı " & m & " numaralı PDF de bulabilirsiniz.", vbInformation, ""
Else
    MsgBox no & " numaralı parça yok.", vbInformation, ""
End If

End Sub

Eğer olmaz ise not kısmında açıklama yaptığım gibi dosyanızı paylaşabilirsiniz.

Not: Altın Üye olmadığınız için siteye dosya ekleyemezsiniz ancak Google Drive, Microsoft OneDrive ya da diğer dosya paylaşım sitelerine yükleyip bağlantı adresi paylaşabilirsiniz.
Benim tercihim reklam vb. yönlendirmeler olmadığı için Google Drive ya da Microsoft OneDrive ile paylaşılması.

 

[Muzaffer Ali]

Merhaba.
Alternatif

Sub Test()
    Dim Aranan As String
    Dim Bulunan As Range
    Dim Bak As Integer
    Dim PDF As String
   
    Aranan = InputBox("Aramak istediğiniz parça no giriniz.")
    If Aranan = "" Then Exit Sub
    Set Bulunan = Range("A:A").Find(what:=Aranan, lookat:=xlWhole)
    If Bulunan Is Nothing Then
        MsgBox "Aradığınız Parça No bulunamadı."
        Exit Sub
    Else
        For Bak = 2 To 5
            If Cells(Bulunan.Row, Bak) = "x" Then
                If PDF = "" Then
                    PDF = Bak
                Else
                    PDF = PDF & " ve " & Bak
                End If
            End If
        Next
        MsgBox PDF & "  numaralı pdf bulabilirsiniz."
    End If
End Sub

 

[uewhes]

Merhaba, tablonuz resimdeki gibi olursa, paylaştığım kodları kullanabilirsiniz.
Ekli dosyayı görüntüle 236973

Option Base 1
Sub test()
no = Application.InputBox("Parça Numarasını Yazınız", "Parça Numarası Arama Ekranı")
If no = False Then Exit Sub
Set sh = Sayfa1
s = sh.Cells(Rows.Count, 1).End(3).Row
a = WorksheetFunction.CountIf(sh.Range("A2:A" & s), no)

If a >= 1 Then
    b = sh.Range("A:A").Find(no).Row
    r = WorksheetFunction.CountIf(sh.Range("B" & b & ":E" & b), "x")
    ReDim d(r)
    r = 1
        For Each h In sh.Range("B" & b & ":E" & b)
            If h.Value = "x" Then
                c = h.Column
                d(r) = sh.Cells(1, c)
                r = r + 1
            End If
        Next
    m = Join(d, " ve ")
    MsgBox no & " numaralı parçayı " & m & " numaralı PDF de bulabilirsiniz.", vbInformation, ""
Else
    MsgBox no & " numaralı parça yok.", vbInformation, ""
End If

End Sub

Ekli dosyayı görüntüle 236974

Eğer olmaz ise not kısmında açıklama yaptığım gibi dosyanızı paylaşabilirsiniz.

Not: Altın Üye olmadığınız için siteye dosya ekleyemezsiniz ancak Google Drive, Microsoft OneDrive ya da diğer dosya paylaşım sitelerine yükleyip bağlantı adresi paylaşabilirsiniz.
Benim tercihim reklam vb. yönlendirmeler olmadığı için Google Drive ya da Microsoft OneDrive ile paylaşılması.

Adem Bey,
Ufak satır değişiklikleri ile vermiş olduğunuz makro ile işimi hallettim. Teşekkür ederim ilginiz için

 

[uewhes]

Merhaba.
Alternatif

Sub Test()
    Dim Aranan As String
    Dim Bulunan As Range
    Dim Bak As Integer
    Dim PDF As String
  
    Aranan = InputBox("Aramak istediğiniz parça no giriniz.")
    If Aranan = "" Then Exit Sub
    Set Bulunan = Range("A:A").Find(what:=Aranan, lookat:=xlWhole)
    If Bulunan Is Nothing Then
        MsgBox "Aradığınız Parça No bulunamadı."
        Exit Sub
    Else
        For Bak = 2 To 5
            If Cells(Bulunan.Row, Bak) = "x" Then
                If PDF = "" Then
                    PDF = Bak
                Else
                    PDF = PDF & " ve " & Bak
                End If
            End If
        Next
        MsgBox PDF & "  numaralı pdf bulabilirsiniz."
    End If
End Sub

Muzaffer Bey,

İlginize teşekkür ederim yardımcı oldu baya

 

[AdemCan]

Rica ederim.