Arama yaparak bir sheetteki bilgiyi başka bir sheete getirmek.

[sakoz]

Sevgili Üstadlar merhaba ,

Bir konuda sizlerin yardımına ihtiyacım var. Ek'te gönderdiğim dosyada bir aya ait ayrı ayrı açılmış sheetler var ve bunların icinde bilgiler var.Benim istediğim hergünü kontrol edecek ve bayi adı INAN ve INAN LÜLEBURGAZ olan bayileri bulacak.Bunu bulduğu yerdeki plakayı liste sheetinde o tarih icin bulacak ve F sütununa X koyacak....

Hepinize şimdiden çok ama çok teşekkür ederim...

Tşk.İyi çalışmalar...

 

[sakoz]

Arkadaşlar yardımcı olabilirmisiniz...

 

[Recep İpek]

Anladığım kadarıyla ekteki dosyada bir çalışma yaptım.Umarım doğrudur.

Sub Kontrol()
Set s1 = Sheets("liste")
s1.Range("f:f").ClearContents

For Each say In Worksheets
If say.Name <> "liste" Then
Set s2 = Sheets(say.Name)
    plaka = s2.Cells(3, "f").Value
    For i = 3 To s2.[e65536].End(3).Row
                If s2.Cells(i, "e").Value = "" Then
            plaka = s2.Cells(i, "e").Offset(1, 1).Value
            ElseIf s2.Cells(i, "e").Value = "INAN" Or s2.Cells(i, "e").Value = "INAN L&#220;LEBURGAZ" Then
            For j = 2 To s1.[a65536].End(3).Row
                If s1.Cells(j, "b").Value = plaka Then
                    s1.Cells(j, "f").Value = "X"
                End If
            Next j
            End If
    Next i
Set s2 = Nothing
End If
Next say
Set s1 = Nothing
MsgBox "Bitti"
End Sub

 

[sakoz]

Sayın Ripek üstadım ,

Öncelikle ilginizden dolayı çok teşekkür ederim. Kusuruma bakmayın.Biraz geç bakabildim.Sadece şöyle bir hata alıyorum.
Mesela , kontrol et butonuna bastığım zaman 02.07 tarihinde VV 4615 plakalı araç 2 ayrı yere gitmiş.liste sheetinde her ikisinede X işareti koymuş.Ayrıca bazı plakalarda ogün INAN bayine gitmemesine rağmen yine X işareti koyuyor.
Tekrar ilgilendiğiniz için çok teşekkür ederim.Ellerinize sağlık

 

[Recep İpek]

2 yere giden bir araç tek mi yazılacak?


INAN bayisine gitmeyenleride yazabilirmisiniz?

 

[sakoz]

Evet sayın ripek ,

2 yere giden bir araç tek yazılacak.Örneğin 02.07 tarihinde VV 4615 plakalı araç 2 ayrı yere gitmiş.Bunlardan birisi INAN digeri başka bir bayi.Benim icin sadece INAN bayisi olan önemli.

INAN bayisine gitmeyenlere örnek olarak ise kontrol et 'e basılınca liste sheetinde;
03.07.2007 34 VN 6541 1832 2,04 3737,28 X
olarak gösteriyor oysa bu plakalı araç 03.07 de başka bayilere gitmiş.Bununda yanına X işareti koyuyor.
Tşk...

 

[Recep İpek]

Burada bir sorun çıkıyor.

Araç aynı gün 2 farklı yere gidiyorsa ve listede başka bir ayırım (tarih+plaka)olmadığı için bunu bulmamız biraz zorlaşıyor.

Bende listedeki Km ile sayfalardaki Km karşılaştırak yapmaya çalıştım.

Aşağıdaki kodları deneyebilirmisiniz?

Sub Kontrol()
Set s1 = Sheets("liste")
s1.Range("f:f").ClearContents

For Each say In Worksheets
If say.Name <> "liste" Then
Set s2 = Sheets(say.Name)
    For i = 3 To s2.[e65536].End(3).Row
        If s2.Cells(i, "e").Value = "" Or s2.Cells(i, "e").Value = "Bayi Ad&#305;" Then
            plaka = s2.Cells(i, "e").Offset(1, 1).Value
            km = s2.Cells(i, "e").Offset(1, 2).Value
        ElseIf s2.Cells(i, "e").Value = "INAN" Or s2.Cells(i, "e").Value = "INAN LULEBURGAZ" Then
            For j = 2 To s1.[a65536].End(3).Row
                If s1.Cells(j, "b").Value = plaka And s1.Cells(j, "c").Value = km Then
                    s1.Cells(j, "f").Value = "X"
                End If
            Next j
        End If
    Next i
Set s2 = Nothing
End If
Next say
Set s1 = Nothing
MsgBox "Bitti"
End Sub

 

[sakoz]

Yine bazı olmaması gereken yerlere X işareti koyuyor üstadım...

 

[veyselemre]

Sub Kontrol2()
    Set s1 = Sheets("liste")
    s1.Range("F:L").ClearContents
    ReDim dizi(1 To 5, 1 To 1)
    For Each say In Worksheets
        If say.Name <> "liste" Then
            For i = 3 To say.[e65536].End(3).Row
                If say.Cells(i, "e").Value Like "INAN*" And say.Cells(i, "G") <> "" Then
                    dizi(1, UBound(dizi, 2)) = say.Cells(i, "D")
                    For x = 2 To 5
                        dizi(x, UBound(dizi, 2)) = say.Cells(i, x + 4)
                    Next x
                    ReDim Preserve dizi(1 To 5, 1 To UBound(dizi, 2) + 1)
                End If
            Next i
        End If
    Next say
    ReDim Preserve dizi(1 To 5, 1 To UBound(dizi, 2) - 1)
    s1.Select

    yy = WorksheetFunction.Transpose(dizi)
    Erase dizi

    [h1].Resize(UBound(yy), UBound(yy, 2)).Value = yy
    For x = 1 To UBound(yy)
        For y = 2 To [a65536].End(3).Row
            If CDate(Cells(y, 1)) <> CDate(yy(x, 1)) Then GoTo atla
            If Cells(y, 2) <> yy(x, 2) Then GoTo atla
            For t = 3 To 4
                If Val(Cells(y, t)) <> Val(yy(x, t)) Then
                    GoTo atla
                End If
            Next t
            Cells(y, "F") = "X"
            Exit For
atla:
        Next y
    Next x
    Set s1 = Nothing
    Erase yy
    MsgBox "Bitti"
End Sub

 

[sakoz]

Sayın veyselemre ,

Sadece 3 tane X işareti koydu.Toplam 14 tane olması gerekiyor...
Ayrıca ilginize teşekkür ederim..

 

[veyselemre]

Soruyu sorarken açıklamanız yetersiz 14 tane bulacağını baştan söylemeniz gerekir. Ve bu 14 taneyi manuel olarak işaretlemeniz iyi olurdu.
Ayrıca siz bir kamyonda çeşitli 1 veya daha çok bayiye mal sevk ediyorsunuz, INAN bayisine hangi seferlerde sevkiyat yapılmış onu bulmak istiyorsunuz, bu şekilde sorsaydınız daha kolay olurdu. Umarım yanlış anlamamışımdır.

Sub Kontrol2()
    Set s1 = Sheets("liste")
    s1.Range("F:L").ClearContents
    ReDim dizi(1 To 5, 1 To 1)
    For Each say In Worksheets
        If say.Name <> "liste" Then
            For i = 3 To say.[e65536].End(3).Row
                If say.Cells(i, "e").Value Like "INAN*" Then
                    dizi(1, UBound(dizi, 2)) = say.Cells(i, "D")
                    say.Select
                    If say.Cells(i, "G") = "" Then
                        bul = say.Cells(i, "G").End(xlUp).Row
                    Else
                        bul = i
                    End If

                    For x = 2 To 5
                        dizi(x, UBound(dizi, 2)) = say.Cells(bul, x + 4)
                    Next x
                    ReDim Preserve dizi(1 To 5, 1 To UBound(dizi, 2) + 1)
                End If
            Next i
        End If
    Next say
    ReDim Preserve dizi(1 To 5, 1 To UBound(dizi, 2) - 1)
    s1.Select

    yy = WorksheetFunction.Transpose(dizi)
    Erase dizi

    [h1].Resize(UBound(yy), UBound(yy, 2)).Value = yy
    For x = 1 To UBound(yy)
        For y = 2 To [a65536].End(3).Row
            If CDate(Cells(y, 1)) <> CDate(yy(x, 1)) Then GoTo atla
            If Cells(y, 2) <> yy(x, 2) Then GoTo atla
            For t = 3 To 4
                If Val(Cells(y, t)) <> Val(yy(x, t)) Then
                    GoTo atla
                End If
            Next t
            Cells(y, "F") = "X"
            Exit For
atla:
        Next y
    Next x
    Set s1 = Nothing
    Erase yy
    MsgBox "Bitti"
End Sub

 

[sakoz]

Sayın Veyselemre üstadım ,

Ellerinize sağlık....Süper oldu...Çok ama çok teşekkür ederim.