Bir parçanın içinde bulunan aksesuraların listesini çekmek.

[silkrblt]

Elimde bir imalat var onun içerisinde olan bir aksesuarların listesini Liste sayfasından nasıl çektirebilirim.
turuncu boyalı ismi yazınca sarı renkli sütunun dolmasını istiyorum kısaca. var mı böyle bir formül.

 

[Muzaffer Ali]

Merhaba.

Form sayfasının kod kısmında bulunan kodları silip aşağıdakileri kopyalayın.
E7 hücresi her değiştikçe kodar otomatik çalışacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim s1 As Worksheet, i As Byte, x As Byte, dizi()
    Dim Bul As Range
    Dim IlkAdres As String
    Dim Say As Long
   
    If Selection.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    If Target.Column = 4 And Target.Row >= 11 Then
        If Target.Value = 0 Then Exit Sub
        Set s1 = ActiveSheet
        x = Target.Value
        ReDim dizi(x)
        For i = 1 To x
            rastgele = WorksheetFunction.RandBetween(-2, 2)
            dizi(i) = rastgele
        Next i
        s1.Range("G" & Target.Row) = Join(dizi, ", ")
    ElseIf Not Intersect(Target, Range("E7")) Is Nothing Then
        Range("B11:D60").ClearContents
       
        With Worksheets("LİSTE")
            Set Bul = .Range("A:A").Find(what:=Range("E7").Value, lookat:=xlWhole)
            If Bul Is Nothing Then
                MsgBox "Girdiğiniz Marka bulunamadı, lütfen kontrol ederek yeniden deneyiniz.", vbExclamation
                Exit Sub
            End If
            IlkAdres = Bul.Address
            Application.EnableEvents = False
            Do
                Say = Cells(60, "B").End(xlUp).Row + 1
                Bul(1, 2).Resize(1, 3).Copy Cells(Say, "B")
                Set Bul = .Range("A:A").FindNext(Bul)
                If IlkAdres = Bul.Address Then Exit Do
            Loop Until Bul Is Nothing
            Application.EnableEvents = True
        End With
    End If
    Application.ScreenUpdating = True
End Sub

 

[silkrblt]

Merhaba.

Form sayfasının kod kısmında bulunan kodları silip aşağıdakileri kopyalayın.
E7 hücresi her değiştikçe kodar otomatik çalışacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim s1 As Worksheet, i As Byte, x As Byte, dizi()
    Dim Bul As Range
    Dim IlkAdres As String
    Dim Say As Long
   
    If Selection.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    If Target.Column = 4 And Target.Row >= 11 Then
        If Target.Value = 0 Then Exit Sub
        Set s1 = ActiveSheet
        x = Target.Value
        ReDim dizi(x)
        For i = 1 To x
            rastgele = WorksheetFunction.RandBetween(-2, 2)
            dizi(i) = rastgele
        Next i
        s1.Range("G" & Target.Row) = Join(dizi, ", ")
    ElseIf Not Intersect(Target, Range("E7")) Is Nothing Then
        Range("B11:J60").ClearContents
       
        With Worksheets("LİSTE")
            Set Bul = .Range("A:A").Find(what:=Range("E7").Value, lookat:=xlWhole)
            If Bul Is Nothing Then
                MsgBox "Girdiğiniz Marka bulunamadı, lütfen kontrol ederek yeniden deneyiniz.", vbExclamation
                Exit Sub
            End If
            IlkAdres = Bul.Address
            Application.EnableEvents = False
            Do
                Say = Cells(60, "B").End(xlUp).Row + 1
                Bul(1, 2).Resize(1, 3).Copy Cells(Say, "B")
                Set Bul = .Range("A:A").FindNext(Bul)
                If IlkAdres = Bul.Address Then Exit Do
            Loop Until Bul Is Nothing
            Application.EnableEvents = True
        End With
    End If
    Application.ScreenUpdating = True
End Sub

Yapınca bu sefer diğer yazılar gitti
filtre ile çözdüm problemi. ama bu seferde diğer makrom çalışmıyor

 

[Muzaffer Ali]

Yapınca bu sefer diğer yazılar gitti
filtre ile çözdüm problemi. ama bu seferde diğer makrom çalışmıyor

Diğer yazılar dediğiniz yerler neresi?
Neredeki yazıların gitmesini istemiyorsunuz?

 

[silkrblt]

Yeşil sütunun sabit klması sarı sütunlu hücrelerin değişmesi istiyorum

 

[Muzaffer Ali]

Sanırım tam tersini söylediniz.

Bir yanlışlık olmasın ilk sorunuzda BCD sütunlarına yazılacak demiştiniz.

Yukarıdaki kodu düzenledim yeniden deneyiniz.