Koşula göre şartlı arama (makrolu)

[abbasonline]

Ekteki sayfa 2 deki tabloyu sayfa 1 e göre doldurmak istiyorum, yardımlarınız için teşekkürler.

 

[abbasonline]

Arkadaşlar kolay gelsin ekteki dosya ile ilgilenebilirmisiniz. Teşekkürler.

 

[Orion1]

Tamam yapıcam.Buna kullanıcı tanımlı fonksiyon yapacam.
Şimdi biraz işim var.İşim bitince yaparım bu gün.

 

[abbasonline]

Teşekkür ederim sağolasın.

 

[Orion1]

Sayfa1de A ve B sütununda 2 yerde tarih var.Hangi tarih sorgulanacak.A sütunundakimi B sütunundakimi,Veya nedir?

 

[abbasonline]

Sayfa 1 Asütünundaki tarih

 

[Orion1]

Dosyanız ektedir.

Option Compare Text

Sub arabul()
Dim k As Range, say As Long, adr As String, alan1 As Range
Dim hcr As Range, son As Long
'On Error Resume Next
Set alan1 = Range("B3:AB7", "B9:AB20")
son = Sheets("Sayfa1").Cells(65536, "C").End(xlUp).Row
For Each hcr In alan1
    hcr.Value = ""
    Set k = Sheets("Sayfa1").Range("C2:C" & son).Find _
    (Cells(hcr.Row, "A").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        Do
            If k.Offset(0, -2).Value >= Range("A1").Value And _
            k.Offset(0, -2).Value <= Range("A2").Value And _
            InStr(1, k.Offset(0, 2).Value, Cells(2, hcr.Column)) > 0 Then
                say = say + 1
            End If
        Set k = Sheets("Sayfa1").Range("C2:C" & son).FindNext(k)
        Loop While Not k Is Nothing And k.Address <> adr
        hcr.Value = say
        say = 0
    End If
Next
MsgBox "İşlem tamalandı"
End Sub

 

[abbasonline]

Evren bey;

Kusura bakmassanız, Dosyayı büyük küçük harfe duyarsız hale ve tasnif kısmınıda çalıştırabilirmiyiz.
ayrıca ikinci satıra yazdığımız kelimeyi, (AraBul) düğmesine tıklatmadan direk tabloya işletebilirmiyiz. Teşekkürler.

 

[Orion1]

Kusura bakmassanız, Dosyayı büyük küçük harfe duyarsız hale ve tasnif kısmınıda çalıştırabilirmiyiz.
ayrıca ikinci satıra yazdığımız kelimeyi, (AraBul) düğmesine tıklatmadan direk tabloya işletebilirmiyiz. Teşekkürler.

Dosyanız ektedir.
Ayrıca kodlar zaten öncedende küçük-büyük harfe duyarlı değillerdir.
Bunuda aşağıda ki kodlarda kırmızı renkli kod sağlıyor.

[B][COLOR="Red"]Option Compare Text[/COLOR][/B]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A3:A20]) Is Nothing Then Exit Sub
Dim k As Range, say As Long, adr As String, alan1 As Range
Dim hcr As Range, son As Long
'On Error Resume Next
Set alan1 = Range("B" & Target.Row & ":AB" & Target.Row & ",AD" & Target.Row & ":AQ" & Target.Row)
son = Sheets("Sayfa1").Cells(65536, "C").End(xlUp).Row
For Each hcr In alan1
    hcr.Value = ""
    If hcr.Column < 30 Then
        sut = "E"
        Else
        sut = "D"
    End If
    Set k = Sheets("Sayfa1").Range("C2:C" & son).Find _
    (Cells(hcr.Row, "A").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        Do
            If Sheets("Sayfa1").Cells(k.Row, "A").Value >= Range("A1").Value And _
            Sheets("Sayfa1").Cells(k.Row, "A").Value <= Range("A2").Value And _
            InStr(1, Sheets("Sayfa1").Cells(k.Row, sut).Value, Cells(2, hcr.Column)) > 0 Then
                say = say + 1
            End If
        Set k = Sheets("Sayfa1").Range("C2:C" & son).FindNext(k)
        Loop While Not k Is Nothing And k.Address <> adr
        hcr.Value = say
        say = 0
    End If
Next
End Sub

 

[abbasonline]

Evren bey, dosyayı indirdim ancak A3 den itibaren A sütunundaki isimler sabit, 2 satırdaki kelimeler değişkendi, teşekkür ederim. Kolay gelsin.

 

[abbasonline]

Evren bey, V2 hücredeki (bir) büyük harfle yazıp A10 daki ANADOLU yu tekrar yazdığımda, V10 hücresinde vermesi gereken değer çıkmıyor, (bir) kelimesini (Bir) şeklinde yazarak aynı işlemi tekrarladığımda, V10 hücresinde değer çıkıyor, ayrıca sadece 2 satırdaki kelimeleri tekrar yazdığımda tablo çalışsın, A3 den itibaren a sütünu sabit kalsa, şu anda A sütununu tekrar yazdığımda tablo çalışıyor.

 

[Orion1]

Evren bey, V2 hücredeki (bir) büyük harfle yazıp A10 daki ANADOLU yu tekrar yazdığımda, V10 hücresinde vermesi gereken değer çıkmıyor, (bir) kelimesini (Bir) şeklinde yazarak aynı işlemi tekrarladığımda, V10 hücresinde değer çıkıyor, ayrıca sadece 2 satırdaki kelimeleri tekrar yazdığımda tablo çalışsın, A3 den itibaren a sütünu sabit kalsa, şu anda A sütununu tekrar yazdığımda tablo çalışıyor.

Dosyanız ektedir.

Option Compare Text

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2:AB2,AD2:AQ2]) Is Nothing Then Exit Sub
Dim k As Range, say As Long, adr As String, alan1 As Range
Dim adr1 As String, adr2 As String
Dim hcr As Range, son As Long, deg As String, deg2 As String
On Error Resume Next
Application.ScreenUpdating = False
If Target.Column < 30 Then
    sut = "E"
    Else
    sut = "D"
End If
adr1 = Range(Cells(3, Target.Column), Cells(7, Target.Column)).Address
adr2 = Range(Cells(9, Target.Column), Cells(20, Target.Column)).Address
Set alan1 = Range(adr1 & "," & adr2)
son = Sheets("Sayfa1").Cells(65536, "E").End(xlUp).Row
For Each hcr In alan1
    hcr.Value = ""
    Set k = Sheets("Sayfa1").Range("C2:C" & son).Find _
    (Cells(hcr.Row, "A").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        adr = k.Address
        Do
            deg = UCase(Replace(Replace(Sheets("Sayfa1").Cells(k.Row, sut).Value, "ı", "I"), "i", "İ"))
            deg2 = UCase(Replace(Replace(Target.Value, "i", "İ"), "ı", "I"))
            If Sheets("Sayfa1").Cells(k.Row, "A").Value >= Range("A1").Value And _
            Sheets("Sayfa1").Cells(k.Row, "A").Value <= Range("A2").Value And _
            InStr(1, deg, deg2) > 0 Then
                say = say + 1
            End If
        Set k = Sheets("Sayfa1").Range("C2:C" & son).FindNext(k)
        Loop While Not k Is Nothing And k.Address <> adr
        hcr.Value = say
        say = 0
    End If
Next
Application.ScreenUpdating = treu
End Sub

 

[abbasonline]

Evren bey çok teşekkürler kusura bakmayın sizlere zahmet verdik, kolay gelsin.

 

[Orion1]

Evren bey çok teşekkürler kusura bakmayın sizlere zahmet verdik, kolay gelsin.

Rica ederim.
İyi çalışmalar.