Çözüldü olasılıklı çoklu arama ve listeleme hak.

bycakir · 26 Şubat 2019

merhaba arkadaşlar.
elimde bir excell listesi var sayfada 4 stunda x sayı ile y sayı arasında aratma yapıp listeletmek istiyorum. excelde açıklama var yardımlarınızı bekliyorum. şimdiden teşekkürler.

Ömer BARAN · 26 Şubat 2019

Merhaba.
Kriter değerleri Sayfa1'de N5:U5 aralığına taşıyıp aşağıdaki kodu çalıştırın.

Rich (BB code):

Sub KRITERLI_LISTELE()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2"): s2.Cells.Clear
ealt = 0: eust = 1000: falt = 0: fust = 1000: galt = 0: gust = 1000: halt = 0: hust = 1000
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If s1.[N5] > 0 And s1.[O5] > 0 Then: ealt = s1.[N5]: eust = s1.[O5]
If s1.[P5] > 0 And s1.[Q5] > 0 Then: falt = s1.[P5]: fust = s1.[Q5]
If s1.[R5] > 0 And s1.[S5] > 0 Then: galt = s1.[R5]: gust = s1.[S5]
If s1.[T5] > 0 And s1.[U5] > 0 Then: halt = s1.[T5]: hust = s1.[U5]
For sat = 2 To s1.Cells(Rows.Count, 1).End(3).Row
    If Val(s1.Cells(sat, "e").Text) >= ealt And Val(s1.Cells(sat, "e").Text) <= eust And _
        Val(s1.Cells(sat, "f").Text) >= falt And Val(s1.Cells(sat, "f").Text) <= fust And _
        Val(s1.Cells(sat, "g").Text) >= galt And Val(s1.Cells(sat, "g").Text) <= gust And _
        Val(s1.Cells(sat, "h").Text) >= halt And Val(s1.Cells(sat, "h").Text) <= hust Then
        say = say + 1: s2sat = s2.Cells(Rows.Count, 1).End(3).Row + 1
        For sut = 1 To 11
            s2.Cells(s2sat, sut) = s1.Cells(sat, sut).Text
        Next
    End If
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
If say > 0 Then s1.[A1:K1].Copy s2.[A1]: MsgBox say & _
    " adet veri satırı Sayfa2'ye aktarıldı.", vbInformation, "..:: Ömer BARAN :..."
If say = 0 Then: MsgBox "Kriterlere uygun veri yok", vbInformation, "..:: Ömer BARAN :..."
s2.Columns.AutoFit: say = Empty: Set s1 = Nothing: Set s2 = Nothing
End Sub

kulomer46 · 26 Şubat 2019

Alternatif olarak aşağıdaki çalışmayı ekliyorum.

Ömer BARAN · 26 Şubat 2019

2 numaralı cevapta verdiğim klasik döngü yöntemi yerine bir de alternatif olarak dizi yöntemini vereyim.
Veri yığını büyüdüğünde, diğer yönteme göre hız farkı belirgin şekilde görülecektir.

Rich (BB code):

Sub KRITERLI_LISTELE_DIZI()
Dim dizi(), liste()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2"): s2.Cells.Clear
ealt = 0: eust = 1000: falt = 0: fust = 1000: galt = 0: gust = 1000: halt = 0: hust = 1000
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If s1.[N5] > 0 And s1.[O5] > 0 Then: ealt = s1.[N5]: eust = s1.[O5]
If s1.[P5] > 0 And s1.[Q5] > 0 Then: falt = s1.[P5]: fust = s1.[Q5]
If s1.[R5] > 0 And s1.[S5] > 0 Then: galt = s1.[R5]: gust = s1.[S5]
If s1.[T5] > 0 And s1.[U5] > 0 Then: halt = s1.[T5]: hust = s1.[U5]

liste = s1.Range("A1:K" & s1.Cells(Rows.Count, 1).End(3).Row).Value
ReDim dizi(1 To UBound(liste), 1 To 11)
For a = 1 To UBound(liste)
    If a = 1 Or _
       (Val(liste(a, 5)) >= ealt And Val(liste(a, 5)) <= eust And _
        Val(liste(a, 6)) >= falt And Val(liste(a, 6)) <= fust And _
        Val(liste(a, 7)) >= galt And Val(liste(a, 7)) <= gust And _
        Val(liste(a, 8)) >= halt And Val(liste(a, 8)) <= hust) Then
        say = say + 1
        For sut = 1 To 11
            dizi(say, sut) = liste(a, sut)
        Next
    End If
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
If say = 0 Then: MsgBox "Kriterlere uygun veri yok", vbInformation, "..:: Ömer BARAN :..."
If say > 0 Then s2.Range("A1").Resize(say, 11) = dizi: MsgBox _
    say - 1 & " adet satır Sayfa2'ye aktarıldı.", vbInformation, "..:: Ömer BARAN :..."
s2.Columns.AutoFit: Erase liste: Erase dizi: Set s1 = Nothing: Set s2 = Nothing
End Sub

veyselemre · 26 Şubat 2019

Kod:

Dim adoCN As Object, rs As Object
Sub temizleCb()
    For i = 1 To 8
        Me.Controls("TextBox" & i).Text = ""
    Next i
    For i = 1 To 4
        Me.Controls("CheckBox" & i).Value = False
    Next i
End Sub
Private Sub btnTemizle_Click()
    Call temizleCb
    Call adoListele
End Sub
Private Sub btnAdoAra_Click()
    adoListele
End Sub
Private Sub CommandButton1_Click()
    If ListBox1.ListCount > 0 Then
        Sheets("Rapor").Range("A2:K" & Rows.Count).ClearContents
    End If
End Sub
Private Sub CheckBox1_Click()
    If CheckBox1.Value Then TextBox2.Text = TextBox1.Text
End Sub
Private Sub CheckBox2_Click()
    If CheckBox2.Value Then TextBox4.Text = TextBox3.Text
End Sub
Private Sub CheckBox3_Click()
    If CheckBox3.Value Then TextBox6.Text = TextBox5.Text
End Sub
Private Sub CheckBox4_Click()
    If CheckBox4.Value Then TextBox8.Text = TextBox7.Text
End Sub
Private Sub UserForm_Initialize()
    Set sh = Sheets("Sayfa1")

    a = Array(45, 45, 200, 70, 65, 65, 65, 65, 50, 50, 50)
    ListBox1.ColumnWidths = Join(a, ",")

    For i = 0 To 10
        With Me.Controls("Label" & i)
            .Width = a(i) - 5
            If i > 0 Then .Left = Me.Controls("Label" & i - 1).Left + Me.Controls("Label" & i - 1).Width + 5
        End With
    Next i
    l = Array(4, 5, 6, 7)
    C = Array(1, 2, 3, 4)
    For i = 1 To 7 Step 2
        With Me.Controls("Textbox" & i)
            .Left = Me.Controls("Label" & l(say)).Left
            Me.Controls("TextBox" & i + 1).Left = .Left + 32
            Me.Controls("CheckBox" & C(say)).Left = .Left
        End With
        say = say + 1
    Next i

    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=yes ; IMEX=1 "
    adoCN.Open
    Set rs = CreateObject("ADODB.Recordset")
    Call adoListele
End Sub
Sub adoListele()
    sart = "    "
    If TextBox1.Text <> "" Then sart = sart + " [ÜST ÇAP] >=" & TextBox1.Text & " AND"
    If TextBox2.Text <> "" Then sart = sart + " [ÜST ÇAP] <=" & TextBox2.Text & " AND"
    If TextBox3.Text <> "" Then sart = sart + " [ALT ÇAP] >=" & TextBox3.Text & " AND"
    If TextBox4.Text <> "" Then sart = sart + " [ALT ÇAP] <=" & TextBox4.Text & " AND"
    If TextBox5.Text <> "" Then sart = sart + " [DIŞ ÇAP] >=" & TextBox5.Text & " AND"
    If TextBox6.Text <> "" Then sart = sart + " [DIŞ ÇAP] <=" & TextBox6.Text & " AND"
    If TextBox7.Text <> "" Then sart = sart + " [YÜKSEKLİK] >=" & TextBox7.Text & " AND"
    If TextBox8.Text <> "" Then sart = sart + " [YÜKSEKLİK] <=" & TextBox8.Text & " AND"

    sart = IIf(Trim(sart) <> "", " Where " & Trim(Left(sart, Len(sart) - 4)), "")
    son = Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row
    strsql = "Select * From [Sayfa1$A1:K" & son & "]" & sart
    'Application.StatusBar = strsql
    rs.Open strsql, adoCN, 1, 1

    If rs.RecordCount > 0 Then
        ListBox1.Column = rs.getrows
        Sheets("Rapor").Range("A2:K" & Rows.Count).ClearContents
        rs.MoveFirst
        Sheets("Rapor").Range("A2").CopyFromRecordset rs
    Else
        MsgBox "Listelenecek uygun kayıt bulunamadı..." & vbCr & strsql, vbInformation
    End If

    rs.Close
    UserForm1.Caption = " >Listelenen : " & ListBox1.ListCount
End Sub

Private Sub UserForm_Terminate()
    adoCN.Close
End Sub

https://yadi.sk/d/vh4-L3XhhJib5A

bycakir · 27 Şubat 2019

@kulomer46 @Ömer BARAN @veyselemre çok teşekkürler elleriniz dert görmesin.

halit3 · 27 Şubat 2019

Bir alternatif dosyada ben ekliyorum kod Sayfa1 deki verileri data sayfasına aktarmaktadır.

PHP:

Sub veri_al()


With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With

sayf1 = "Sayfa1"
sayf2 = "data"


Worksheets(sayf2).Range(Worksheets(sayf2).Cells(2, 1), Worksheets(sayf2).Cells(Rows.Count, "k")).ClearContents

For r = 2 To Worksheets(sayf1).Cells(Rows.Count, "A").End(3).Row
deg = 0
With Worksheets(sayf1)
If .Cells(r, "e").Value >= .Cells(19, "m").Value And .Cells(r, "e").Value <= .Cells(19, "n").Value Then
deg = 1
End If
If .Cells(r, "f").Value >= .Cells(19, "o").Value And .Cells(r, "f").Value <= .Cells(19, "p").Value Then
deg = 1
End If
If .Cells(r, "g").Value >= .Cells(19, "q").Value And .Cells(r, "g").Value <= .Cells(19, "r").Value Then
deg = 1
End If
If .Cells(r, "h").Value >= .Cells(19, "s").Value And .Cells(r, "h").Value <= .Cells(19, "t").Value Then
deg = 1
End If

End With

If deg = 1 Then
son = Worksheets(sayf2).Cells(Rows.Count, "A").End(3).Row + 1
If son < 2 Then son = 2
For i = 1 To 11
Worksheets(sayf2).Cells(son, i).Value = Worksheets(sayf1).Cells(r, i).Value
Next i
End If

Next r

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With
MsgBox "işlem tamam"

End Sub

bycakir · 27 Şubat 2019

@halit3 çok teşekkürler.

kulomer46 · 27 Şubat 2019

bycakir' Alıntı:
@kulomer46 @Ömer BARAN @veyselemre çok teşekkürler elleriniz dert görmesin.

Selamlar...

veyselemre · 27 Şubat 2019

Kod:

Sub sayfadanAra()

    Sheets("Rapor").Range("A2:K" & Rows.Count).ClearContents
    kriter = Application.Index(Sheets("Sayfa1").Range("M20:T20").Value, 0)

    For i = 1 To 7 Step 2
        If kriter(i) = "" Then kriter(i) = 0
        If kriter(i + 1) = "" Then kriter(i + 1) = 10 ^ 10
    Next i

    liste = Sheets("Sayfa1").Range("A1:K" & Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row).Value

    sat = 1
    For i = 2 To UBound(liste)
        say = -1
        uygun = True
        For ii = 5 To 8
            say = say + 2
            If Not (CDbl(liste(i, ii)) >= kriter(say) And CDbl(liste(i, ii)) <= kriter(say + 1)) Then
                uygun = False
                Exit For
            End If
        Next ii
        If uygun Then sat = sat + 1: Sheets("Rapor").Cells(sat, 1).Resize(, 11).Value = Application.Index(liste, i)
    Next i

    MsgBox IIf(sat = 1, "Kriterlere uygun veri yok", "Listelenen kayıt sayısı : " & sat - 1), vbInformation
    Sheets("Rapor").Select

End Sub

halit3 · 27 Şubat 2019

kod:

[

PHP:

Sub veri_al2()

sayf1 = "Sayfa1"
sayf2 = "data"

Worksheets(sayf2).Range(Worksheets(sayf2).Cells(2, 1), Worksheets(sayf2).Cells(Rows.Count, "k")).ClearContents
Data1 = Worksheets(sayf1).Range(Worksheets(sayf1).Cells(1, 1), Worksheets(sayf1).Cells(Rows.Count, "k")).Cells
ReDim veri(1 To UBound(Data1), 1 To 11)

For r = 2 To Worksheets(sayf1).Cells(Rows.Count, "A").End(3).Row
With Worksheets(sayf1)
sut = 13
For j = 5 To 8
If .Cells(r, j).Value >= .Cells(19, sut).Value And .Cells(r, j).Value <= .Cells(19, sut + 1).Value Then
sut = sut + 2
GoTo atla1
End If
Next j
End With
GoTo atla2
atla1:
sat = sat + 1
For i = 1 To 11
veri(sat, i) = Data1(r, i)
Next i
atla2:
Next r

Worksheets(sayf2).Range("A2").Resize(sat, 11) = veri
MsgBox "işlem tamam"

End Sub

erdalerolayas · 4 Mayıs 2024

Bazı değişiklik yapıldı

Çözüldü olasılıklı çoklu arama ve listeleme hak.

bycakir

Ekli dosyalar

Ömer BARAN

Uzman

kulomer46

Ekli dosyalar

Ömer BARAN

Uzman

veyselemre

Özel Üye

Ekli dosyalar

bycakir

halit3

Uzman

Ekli dosyalar

bycakir

kulomer46

veyselemre

Özel Üye

halit3

Uzman

erdalerolayas

Ekli dosyalar