Çoklu Veri Arama

[Biray3550]

Merhaba,
A Kolonundaki çoklu veriyi, Sayfalarda cümlenin ilk 3 harfini alacak ve sonundaki rakamların hepsini alıp arayacak ve Sayfa1'e dizecek.
Umarım anlatabildim.
Teşekkür ederim.

 

[DoğanD]

Merhaba,

Boş bir modüle ekleyip dener misiniz?

Sub deneme()
Dim i, y, j, ss, say, satir As Integer
Dim aranan As String
satir = 2
For i = 2 To Sayfa1.Range("A" & Rows.Count).End(xlUp).Row
say = 0
aranan = Sayfa1.Cells(i, 1)
For ss = Len(Trim(aranan)) To 1 Step -1
If IsNumeric(Mid(Trim(aranan), ss, 1)) Then say = say + 1
Next ss
    For y = 2 To ThisWorkbook.Sheets.Count
        For j = 2 To Sheets(y).Range("A" & Rows.Count).End(xlUp).Row
            If Trim(Sheets(y).Cells(j, 2)) Like Left(aranan, 3) & "*" & Right(aranan, say) Then
                Sayfa1.Cells(satir, 2) = Sheets(y).Name
                Sayfa1.Cells(satir, 3) = Replace(Sheets(y).Cells(j, 2).Address, "$", "")
                Sayfa1.Cells(satir, 4) = Sheets(y).Cells(j, 2)
                Sayfa1.Cells(satir, 5) = Sheets(y).Cells(j, 3)
                satir = satir + 1
            End If
        Next j
    Next y
Next i
End Sub

 

[Biray3550]

Örnek dosyada çalıştı teşekkür ederim. Kendi dosyama uyguladığımda If Trim(Sheets.Cells(j, 2)) Like Left(aranan, 3) & "*" & Right(aranan, say) Then burada hata veriyor
Type mismatch (Error 13)

 

[DoğanD]

Orijinal verilerinizden bir kısım paylaşabilirseniz bakalım. Aranan kelime tipinde problem olabilir.

 

[Korhan Ayhan]

Ofis 365 sürümü için biraz yardımcı sütun desteğiyle alternatif olsun..

 

[veyselemre]

Sub test()
    Dim sh As Worksheet, reg As Object, elem, a, pattern, say
    Dim dic As Object

    Set reg = CreateObject("VBScript.Regexp")
    Set dic = CreateObject("Scripting.Dictionary")
    reg.pattern = "(^\D{3})([\D]*)(\d+$)"

    With Sheets("Sayfa1")
        For Each elem In .Range("A2:A" & .Cells(Rows.Count, 1).End(3).Row).Value
            If reg.test(elem) Then
                a = WorksheetFunction.Proper(reg.Replace(elem, "($1)(\D)+($3$)"))
                dic.Add a, Null
            End If
        Next elem
    End With

    pattern = Join(dic.keys, "|")
    reg.pattern = pattern
    Debug.Print pattern
    reg.ignorecase = True
    say = 2
    For Each sh In Sheets
        If sh.Name <> "Sayfa1" Then
            For Each elem In sh.Range("B2:B" & sh.Cells(Rows.Count, 2).End(3).Row)
                If reg.test(elem.Value) Then
                    With Sheets("Sayfa1")
                        .Cells(say, 2).Value = sh.Name
                        .Cells(say, 3).Value = elem.Address(0, 0)
                        .Cells(say, 4).Value = elem.Value
                        .Cells(say, 5).Value = elem.Offset(, 1).Value
                    End With
                    say = say + 1
                End If
            Next elem
        End If
    Next sh
End Sub

 

[Biray3550]

Orijinal verilerinizden bir kısım paylaşabilirseniz bakalım. Aranan kelime tipinde problem olabilir.

Dosya çok büyük ve 26 sayfa var. Üzerinde çalışmam lazım. ayıklamak için.

 

[Biray3550]

Sub test()
    Dim sh As Worksheet, reg As Object, elem, a, pattern, say
    Dim dic As Object

    Set reg = CreateObject("VBScript.Regexp")
    Set dic = CreateObject("Scripting.Dictionary")
    reg.pattern = "(^\D{3})([\D]*)(\d+$)"

    With Sheets("Sayfa1")
        For Each elem In .Range("A2:A" & .Cells(Rows.Count, 1).End(3).Row).Value
            If reg.test(elem) Then
                a = WorksheetFunction.Proper(reg.Replace(elem, "($1)(\D)+($3$)"))
                dic.Add a, Null
            End If
        Next elem
    End With

    pattern = Join(dic.keys, "|")
    reg.pattern = pattern
    Debug.Print pattern
    reg.ignorecase = True
    say = 2
    For Each sh In Sheets
        If sh.Name <> "Sayfa1" Then
            For Each elem In sh.Range("B2:B" & sh.Cells(Rows.Count, 2).End(3).Row)
                If reg.test(elem.Value) Then
                    With Sheets("Sayfa1")
                        .Cells(say, 2).Value = sh.Name
                        .Cells(say, 3).Value = elem.Address(0, 0)
                        .Cells(say, 4).Value = elem.Value
                        .Cells(say, 5).Value = elem.Offset(, 1).Value
                    End With
                    say = say + 1
                End If
            Next elem
        End If
    Next sh
End Sub

Aynı hata verdi. Type mismatch (Error 13)

 

[DoğanD]

Ayıklamanıza yada tümünü iletmenize gerek yok. Aranan kelimelerden birkaç tane ve bulacağı yerlerdeki versiyonlardan birkaç tane yeterli. Çünkü belli ki örnek dosyanızdan daha farklı verilere sahipsiniz.

 

[Biray3550]

450 Bin stok var, hepsi de değişik ve hepsi de aranıyor.

 

[Korhan Ayhan]

Debug diyerek hata veren satırı inceleyebilirsiniz.

Mesela hata veren satırda j değişkeni hangi değeri gösteriyor. O satıra odaklanıp hataya neyin sebep olduğunu tespit edebilirsiniz.

 

[Korhan Ayhan]

Bu arada satır sayısı yüksek olduğu için veyselemre beyin koduna odaklanmanızı tavsiye ederim.

 

[Biray3550]

Teşekkür ederim. Uygun olunca deneyeceğim.

 

[Biray3550]

For Each elem In .Range("A2:A" & .Cells(Rows.Count, 1).End(3).Row).Value Bu satırı

Bu satırla düzenleyince düzeldi For Each elem In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
Hepinize çok teşekkür ederim.