Verileri Ayırma

[barokatnd]

Arkadaşlar merhaba;
Değerleri karışık olarak girdiğim bir listem var ve ben bu listeden verileri ayırarak çekmek istiyorum. Forumda benzer örnekleri inceledim ama istediğimi yapamadım. Ekli dosyada da ne yapmak istediğimi anlattım. İlgilenen arkadaşlara şimdiden teşekkür ederim.

 

[ÖmerFaruk]

Liste sayfasını KOD bölümüne direkt yapıştırın.
Not: Aynı olaya ait farklı kod varsa birleştirmeniz ya da silmeniz önerilir.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Sütun As Integer
Dim i As Integer
Dim k As Integer

    If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    If Selection.Cells.Count > 1 Then Exit Sub
    Sat = Target.Row
    Select Case Target
        Case "KÜÇÜK"
            Sütun = 5
        Case "ORTA"
            Sütun = 8
        Case "BÜYÜK"
            Sütun = 11
        Case Else
            MsgBox "Ebat hatalı girilmiş" & vbCrLf & "Doğru Ebat : KÜÇÜK - ORTA - BÜYÜK"
            GoTo Son
    End Select
    If WorksheetFunction.CountA(Range("C" & Target.Row, "E" & Target.Row)) > 1 Then
        MsgBox "Dolu satırda ebat tanımlanamaz."
        GoTo Son
    End If
    For i = 4 To WorksheetFunction.Count(Worksheets("DATA").Range("A:A")) + 3
        Select Case Left(Worksheets("DATA").Range("B" & i), 1)
            Case "A"
                Süt = Sütun + 0
            Case "B"
                Süt = Sütun + 1
            Case Else
                Süt = Sütun + 2
        End Select
        If Worksheets("DATA").Cells(i, Süt) <> "" Then
            Application.EnableEvents = False
            k = k + 1
            Range("C" & Target.Row + k) = Worksheets("DATA").Range("B" & i)
            Range("D" & Target.Row + k) = Worksheets("DATA").Range("C" & i)
            Range("E" & Target.Row + k) = Worksheets("DATA").Range("D" & i)
            Application.EnableEvents = True
        End If
    Next i
    MsgBox "İşlem Tamam"
    Range("B" & Target.Row + k + 1).Activate
    Exit Sub
Son:
    Application.EnableEvents = False
    Target = ""
    Application.EnableEvents = True
End Sub

 

[barokatnd]

Sayın @NextLevel , size çok teşekkür ederim, emeğinize sağlık. Sorunsuz bir şekilde çalıştı.

 

[barokatnd]

Bir şey daha sormak istiyorum merakımdan, tablodaki ebat kısmına aradığım değerler haricinde bir şey yazdığımda o değerin de gözükmesi için kodda nereyi değiştirmemiz gerekir?

 

[ÖmerFaruk]

Aradığınız Değer ORTA-KÜÇÜK-BÜYÜK değil mi?
kastınız nedir?

 

[barokatnd]

Evet aradığım değerler onlar, sadece merak ettiğimden soruyorum. örneğin ebat kısmına "çok büyük" yazdığımda değer aramasın ama "çok büyük " yazısı ebat kısmında gözüksün şeklinde de olabilir mi?

 

[ÖmerFaruk]

Sadece kodun aşağıdaki kısmını değiştirin

Case Else
MsgBox "Ebat hatalı girilmiş" & vbCrLf & "Doğru Ebat : KÜÇÜK - ORTA - BÜYÜK"
Exit Sub
End Select

 

[barokatnd]

Vakit ayırıp ilgilendiğiniz için tekrar teşekkür ederim.