sekme oluşturarak başka bir sayfadan koşullu veri çekme

[refleksif24]

Arkadaşlar merhaba

İsteğim şudur.

- sayfa1 e sayfa2 den veri çekeceğim. sayfa2 de bir sütunda ürün gruplarım, diğer sütunda teknik bilgilerim olacak. ( VARSAYALIM Kİ SAYFA2 DE VANA, PETEK, BORU olsun ve hemen yan sütunlarında bunlara ait teknik bilgiler olsun )
- sayfa1 de aynı satır üzerinde birbirine koşullarla bağlanmış sekmeler olacak.
- yani ben sayfa1 de a1 hücresinde bir sekme açacağım ve sekmeye diyelim ki "vana" yazacağım. vanayı gidip sayfa2 den çekecek.
- sayfa2 den "vana" yı çektiğinde sayfa1 de vananın hemen yan satırındaki sekmede sadece vanaya ait teknik bilgiler filtrelenecek, diğer bütün ürün gruplarına ait teknik bilgiler gözükmeyecek.

esasen yapmak istediğim şey yüzlerce iş kalemini sistematik olarak yan yana sekmelerde filtrelemek

böyle bir şey olabilir mi?

 

[Korhan Ayhan]

İşlemleri örnek dosya üzerinde açıklamanız çözüm için faydalı olacaktır.

 

[onurmk]

Aynı şeyi ben de yapmaya çalışıyorum bir türlü cevap alamadım.

 

[refleksif24]

İşlemleri örnek dosya üzerinde açıklamanız çözüm için faydalı olacaktır.

dosya eklenmiştir

 

[Korhan Ayhan]

Ekteki örnek dosyayı inceleyiniz.

İsteğe göre geliştirilebilir.

Kullanılan kod (Sayfanın kod bölümüne uygulayın);

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim S1 As Worksheet, X As Long, Y As Long, Say As Long, Liste()
    
    Set S1 = Sheets("Veriler")
    
    If Target.Row > 1 Then
        If Target.Column = 2 Then
            For X = 2 To S1.Cells(S1.Rows.Count, "B").End(xlUp).Row
                If WorksheetFunction.CountIf(S1.Range("B2:B" & X), S1.Cells(X, "B")) = 1 Then
                    Say = Say + 1
                    ReDim Preserve Liste(1 To Say)
                    For Y = 1 To UBound(Liste)
                        Liste(Say) = S1.Cells(X, "B").Value
                    Next
                End If
            Next
            With Target
                .Validation.Delete
                If Say > 0 Then .Validation.Add Type:=xlValidateList, Formula1:=Join(Liste, ",")
            End With
        End If
    
        If Target.Column = 3 Then
            For X = 2 To S1.Cells(S1.Rows.Count, "C").End(xlUp).Row
                If S1.Cells(X, "B") = Cells(Target.Row, "B") Then
                    If WorksheetFunction.CountIf(S1.Range("C2:C" & X), S1.Cells(X, "C")) = 1 Then
                        Say = Say + 1
                        ReDim Preserve Liste(1 To Say)
                        For Y = 1 To UBound(Liste)
                            Liste(Say) = S1.Cells(X, "C").Value
                        Next
                    End If
                End If
            Next
            With Target
                .Validation.Delete
                If Say > 0 Then .Validation.Add Type:=xlValidateList, Formula1:=Join(Liste, ",")
            End With
        End If
    
        If Target.Column = 4 Then
            For X = 2 To S1.Cells(S1.Rows.Count, "D").End(xlUp).Row
                If S1.Cells(X, "B") = Cells(Target.Row, "B") And S1.Cells(X, "C") = Cells(Target.Row, "C") Then
                    If WorksheetFunction.CountIf(S1.Range("D2:D" & X), S1.Cells(X, "D")) = 1 Then
                        Say = Say + 1
                        ReDim Preserve Liste(1 To Say)
                        For Y = 1 To UBound(Liste)
                            Liste(Say) = S1.Cells(X, "D").Value
                        Next
                    End If
                End If
            Next
            With Target
                .Validation.Delete
                If Say > 0 Then .Validation.Add Type:=xlValidateList, Formula1:=Join(Liste, ",")
            End With
        End If
    End If
End Sub

 

[refleksif24]

Ekteki örnek dosyayı inceleyiniz.

İsteğe göre geliştirilebilir.

Kullanılan kod (Sayfanın kod bölümüne uygulayın);

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim S1 As Worksheet, X As Long, Y As Long, Say As Long, Liste()
    
    Set S1 = Sheets("Veriler")
    
    If Target.Row > 1 Then
        If Target.Column = 2 Then
            For X = 2 To S1.Cells(S1.Rows.Count, "B").End(xlUp).Row
                If WorksheetFunction.CountIf(S1.Range("B2:B" & X), S1.Cells(X, "B")) = 1 Then
                    Say = Say + 1
                    ReDim Preserve Liste(1 To Say)
                    For Y = 1 To UBound(Liste)
                        Liste(Say) = S1.Cells(X, "B").Value
                    Next
                End If
            Next
            With Target
                .Validation.Delete
                If Say > 0 Then .Validation.Add Type:=xlValidateList, Formula1:=Join(Liste, ",")
            End With
        End If
    
        If Target.Column = 3 Then
            For X = 2 To S1.Cells(S1.Rows.Count, "C").End(xlUp).Row
                If S1.Cells(X, "B") = Cells(Target.Row, "B") Then
                    If WorksheetFunction.CountIf(S1.Range("C2:C" & X), S1.Cells(X, "C")) = 1 Then
                        Say = Say + 1
                        ReDim Preserve Liste(1 To Say)
                        For Y = 1 To UBound(Liste)
                            Liste(Say) = S1.Cells(X, "C").Value
                        Next
                    End If
                End If
            Next
            With Target
                .Validation.Delete
                If Say > 0 Then .Validation.Add Type:=xlValidateList, Formula1:=Join(Liste, ",")
            End With
        End If
    
        If Target.Column = 4 Then
            For X = 2 To S1.Cells(S1.Rows.Count, "D").End(xlUp).Row
                If S1.Cells(X, "B") = Cells(Target.Row, "B") And S1.Cells(X, "C") = Cells(Target.Row, "C") Then
                    If WorksheetFunction.CountIf(S1.Range("D2:D" & X), S1.Cells(X, "D")) = 1 Then
                        Say = Say + 1
                        ReDim Preserve Liste(1 To Say)
                        For Y = 1 To UBound(Liste)
                            Liste(Say) = S1.Cells(X, "D").Value
                        Next
                    End If
                End If
            Next
            With Target
                .Validation.Delete
                If Say > 0 Then .Validation.Add Type:=xlValidateList, Formula1:=Join(Liste, ",")
            End With
        End If
    End If
End Sub

Hocam. Muhteşem olmuş. Ellerine sağlık. Şöyle bir geliştirme de yapabilirmiyiz.

Şu anda mesela Ürün grubu Boru iken diğer sekmelerde FCU ya ait bilgiler kalabiliyor, sonradan değiştirdiğimde. Ben Boruyu seçtiğimde diğer sekmelerde otomatikman ya boşa çıksa ya da tek seçenek varsa onu getirse.

Yani bu son söylediğim olmasa da olur ama hata riskini azaltmak açısından faydalı olur diye düşünüyorum.

 

[refleksif24]

süpersin hocam.