bir sütundaki değeri başka sütunlarda olup olmadığını kontrol etmek

[u.L.a.s]

B sütununda bulunan bir veriyi E sütununda H sütununda K sütununda N sütununda ve Q sütununda bakıp aynısı var ise S sütununda o verinin aynısını yazsın.

yani B2 de bulunan 1.1.1.1 verisi yukarıda belirttiğim sütunlarda varsa S sütununda ilk sırada yazsın. yani o sütunlardan birisinde olduğunun göstergesi olarak.

B3 baktığımızda 2.2.2.2 verisi var bu hiç bir sütunda yok. dolayısıyla bu veriyi S sütununa yazmayacak

bu şekilde sıra ile bakıp olan veriyi yazıp olmayan veriyi yazmayacak.

bilgi ve yardımlarınızı rica ederim

http://s7.dosya.tc/server4/12tzoi/ornek.rar.html

 

[hitmen06]

S1 'e "=EĞER(W2="";"";W2)"
t1 ' e "=EĞERSAY($E$2:$E$100;B2)+EĞERSAY($H$2:$H$100;B2)+EĞERSAY($K$2:$K$100;B2)+EĞERSAY($N$2:$N$100;B2)+EĞERSAY($Q$2:$Q$100;B2)"
u1 'e "=EĞER(T2="";"";B2)" formüllerini yazarak aşağı çekin.
T,U, V ve W sutunlarını gizleyin

makroya da
Sub sirala()


Range("v2:v100").Value = Range("t2:t100").Value
Range("w2:w100").Value = Range("u2:u100").Value

Columns("V2:W100").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sayfa3").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sayfa3").Sort.SortFields.Add Key:=Range("V2:V100") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sayfa3").Sort
.SetRange Range("V2:W100")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("S:S").Select
Selection.NumberFormat = "0"
End Sub
kodunu yazın.

 

[Ziynettin]

Bu şekilde deneyiniz.

Sub yaz()
son = Range("B:Q").Find("?", , , , xlByRows, xlPrevious).Row
a = Range("B2:Q" & son)
Set dic = CreateObject("scripting.dictionary")

    For i = 1 To UBound(a)
        For j = 4 To UBound(a, 2) Step 3
            If a(i, j) <> "" Then
                dic(a(i, j)) = dic(a(i, j)) + 1
            End If
        Next j
    Next i

ReDim b(1 To UBound(a), 1 To 1)

    For i = 1 To UBound(a)
        If dic(a(i, 1)) > 0 Then
            say = say + 1
            b(say, 1) = a(i, 1)
        End If
    Next i
    
[S2].Resize(say) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[u.L.a.s]

Çok güzel çok teşekkür ederim.

Peki bu versiyonun dışında şöyle bir versiyonda yapabilir miyiz.

B2 hücresinde bulunan veri E sütununda H sütununda K sütununda N sütununda ve Q sütununda bakıp aynısı hepsinde varsa S sütununda yazsın. Eğer birisinde dahi yoksa yazmasın bu veriyi.

 

[KMLZDMR]

Sayın "hitmen06" s1,t1,u1 hücrelerine belirttiğiniz formülleri uyguladım. #AD? hatası almaktayım.
ayrıca W2 hücresine ilişkin bir açıklama yok. bu formülü de anlamadım.
lütfen Excel2003'e göre formülü düzenler misiniz?

 

[u.L.a.s]

Bu şekilde deneyiniz.

Sub yaz()
son = Range("B:Q").Find("?", , , , xlByRows, xlPrevious).Row
a = Range("B2:Q" & son)
Set dic = CreateObject("scripting.dictionary")

    For i = 1 To UBound(a)
        For j = 4 To UBound(a, 2) Step 3
            If a(i, j) <> "" Then
                dic(a(i, j)) = dic(a(i, j)) + 1
            End If
        Next j
    Next i

ReDim b(1 To UBound(a), 1 To 1)

    For i = 1 To UBound(a)
        If dic(a(i, 1)) > 0 Then
            say = say + 1
            b(say, 1) = a(i, 1)
        End If
    Next i
    
[S2].Resize(say) = b
MsgBox "İşlem tamam.", vbInformation
End Sub

Örnek dosya aşağıdaki gibidir. bir önceki postta anlattığım şekilde olmasını istiyorum bunun için yardımlarınızı rica ederim

http://s7.dosya.tc/server4/ww7v4p/ornek.rar.html

 

[Ziynettin]

Buyrun...

Sub sutunlarda_ara()
son = Range("B:Q").Find("?", , , , xlByRows, xlPrevious).Row
a = Range("B2:Q" & son)
Set d1 = CreateObject("scripting.dictionary")
Range("S2:S" & Rows.Count).ClearContents
    For i = 1 To UBound(a)
        If a(i, 1) <> "" And Not d1.exists(a(i, 1)) Then
            d1(a(i, 1)) = ""
        End If
    Next i
    
    For j = 1 To UBound(a, 2) Step 3
        Set d2 = CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, j) <> "" And d1.exists(a(i, j)) Then
                If Not d2.exists(a(i, j)) Then
                    d2(a(i, j)) = ""
                End If
            End If
        Next i
    Next j
    
    If d2.Count > 0 Then
        ReDim b(1 To d2.Count, 1 To 1)
        For Each v In d2.keys
            say = say + 1
            b(say, 1) = v
        Next v
        [S2].Resize(say) = b
        MsgBox "İşlem tamam.", vbInformation
    Else
        MsgBox "Kayıt bulunamadı.", vbCritical
    End If
End Sub

 

[u.L.a.s]

@Ziynettin üstadım emeğine bilgine sağlık çok teşekkür ederim