İlgili hücreye gitmesi

[igultekin2000]

iyi akşamlar;
stok listesini tek kalem de görmek için Sayfa1' de çizelge hazırladım. Ürünün cinsi , rengi ve bulunduğu hücre rengi olarak 3 kriterli çoketopla yapıyorum. Düşündüğüm şey, Sayfa1' deki adet toplamında hücreye çift tıkladığmda veya farklı bir şekilde İP PERDE çalışma sayfasındak ilgili hücrenin D sütunudaki adet kısmına gitmesi. Biraz karışık gibi ama çözüm arıyorum, teşekkürler.

 

[Muzaffer Ali]

Merhaba.
Sayfa1 adlı sayfanın kod kısmına aşağıdaki kodları kopyalayın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Bak As Integer
    Dim Cinsi As String
    Dim Rengi As String
    Cancel = True
    Cinsi = Cells(Target.Row, "A").Text
    Rengi = Cells(1, Target.Column).Text
    If Intersect(Target, Range("B:AE")) Is Nothing Or Target.Row = 1 Then Exit Sub
    With Worksheets("İP PERDELER")
        For Bak = 3 To .Cells(Rows.Count, "C").End(3).Row
        Dim i
        i = .Cells(Bak, "B").Text
        i = .Cells(Bak, "C").Text
            If .Cells(Bak, "B").Text = Cinsi And .Cells(Bak, "C").Text = Rengi Then
                .Activate
                .Cells(Bak, "D").Activate
                Exit Sub
            End If
        Next
    End With
    MsgBox "Cinsi: '" & Cinsi & "' Rengi: '" & Rengi & "' olan kayıt bulunamadı.", vbExclamation
End Sub

 

[igultekin2000]

Merhaba.
Sayfa1 adlı sayfanın kod kısmına aşağıdaki kodları kopyalayın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Bak As Integer
    Dim Cinsi As String
    Dim Rengi As String
    Dim SayfaVar As Boolean
    Cancel = True
    Cinsi = Cells(Target.Row, "A").Text
    Rengi = Cells(1, Target.Column).Text
    If Intersect(Target, Range("B:AE")) Is Nothing Or Target.Row = 1 Then Exit Sub
    For Bak = 1 To Worksheets.Count
        If Worksheets(Bak).Name = Cinsi Then
            SayfaVar = True
        End If
    Next
    If SayfaVar = False Then
        MsgBox "'" & Cinsi & "' Sayfası bulunamıyor. Lütfen sayfa adlarını kontrol ediniz.", vbExclamation
        Exit Sub
    End If
    With Worksheets(Cinsi)
        For Bak = 3 To .Cells(Rows.Count, "C").End(3).Row
            If .Cells(Bak, "C").Text = Rengi Then
                .Activate
                .Cells(Bak, "D").Activate
                Exit Sub
            End If
        Next
    End With
    MsgBox "'" & Rengi & "' Adlı Renk bulunamadı. Lütfen renkleri kontrol ediniz.", vbExclamation
End Sub

sayfa bulunamıyor şeklinde hata verdi, çözemedim.

 

[Muzaffer Ali]

Kodları düzelttim. Önceki kodları silin yukarıdaki kodları yeniden deneyin.

 

[igultekin2000]

Elinize sağlık, çok teşekkür ederim. gayet pratik çalışıyor, iyi çalışmalar.

 

[igultekin2000]

Merhaba.
Sayfa1 adlı sayfanın kod kısmına aşağıdaki kodları kopyalayın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Bak As Integer
    Dim Cinsi As String
    Dim Rengi As String
    Cancel = True
    Cinsi = Cells(Target.Row, "A").Text
    Rengi = Cells(1, Target.Column).Text
    If Intersect(Target, Range("B:AE")) Is Nothing Or Target.Row = 1 Then Exit Sub
    With Worksheets("İP PERDELER")
        For Bak = 3 To .Cells(Rows.Count, "C").End(3).Row
        Dim i
        i = .Cells(Bak, "B").Text
        i = .Cells(Bak, "C").Text
            If .Cells(Bak, "B").Text = Cinsi And .Cells(Bak, "C").Text = Rengi Then
                .Activate
                .Cells(Bak, "D").Activate
                Exit Sub
            End If
        Next
    End With
    MsgBox "Cinsi: '" & Cinsi & "' Rengi: '" & Rengi & "' olan kayıt bulunamadı.", vbExclamation
End Sub

Kod için tekrar tüşekkür ederim, sorunsuz çalışıyor, ancak. A1 hücresindeki açılır penceredeki numaralar da ilgili depoyu gösteriyor. Cinsi, Rengi seçeneğine Depo' da eklenebilse başka işlemlerimde de kullanacağım için çok daha pratik olacak. Epey Deneme yaptım ama üçüncü alternatifi ilave edemedim. Yani A1 hücresini Dim' le atayıp, If.Cells(Bak,"B"... seçeneğine İP PERDELER seçeneğindeki F hücresinide katabilmek. Denemeyle tuturamadım. Teşekkürler.