İki sütundan değişken duruma göre veri almak

[zulkarneyn37]

Sonda No	Derinlik	Bunyesinifi
1​	0-20	Tın		Üst Bünye
1​	20-60	Killi Tın		Alt Bünye
2​	0-20	Killi Tın		Üst Bünye
3​	0-10	Killi Tın		Üst Bünye
4​	0-20	Tın		Üst Bünye
4​	20-40	Killi Tın		Alt Bünye
6​	0-20	Killi Tın		Üst Bünye
6​	20-30	Killi Tın		Alt Bünye
7​	0-25	Tın		Hem Alt Hem Üst Bünye
8​	0-30	Killi Tın		Hem Alt Hem Üst Bünye
9​	0-20	Killi Tın		Üst Bünye
9​	20-50	Killi Tın		Alt Bünye
9​	50-90	Tın		Bunu almayacak
9​	90-120	Killi Tın		Bunu almayacak

Sonda No	Üst Bünye	Alt Bünye
1​	Tın	Killi Tın
2​	Killi Tın
3​	Killi Tın
4​	Tın	Killi Tın
6​	Killi Tın	Killi Tın
7​	Tın	Tın
8​	Killi Tın	Killi Tın
9​	Killi Tın	Killi Tın

Arkadaşlar Merhaba;

Üstteki veri ham verimiz. Binlerce satır olabilir. Soldaki sütun sonda numaraları. Bu noktalardan değişken derinliklerde toprak örneği alıyoruz ve buna benzer bir tablo ile sonuçlar geliyor. Toprak örnekleri derinlikleri değişebiliyor. Genel olarak 0-20, 20-50, 50-90, 90-120 şeklinde olsa da bazen derin olmayan yerlerden 0-20 ve 20-30 şeklinde örnek alınabiliyor. Buradaki varyasyonda pek standart yok diyebilirim. Alttaki veride üstekinin istediğim hale dönüşmüş hali. Sonda numaralarından her birinden bir tane var. Ben bu veriden alt toprak tekstürü ve üst toprak tekstürünü otomatik aldırmak istiyorum. Alt veya üst olmasını 20 cm derinlik sınırı belirliyor. eğer bir noktadan sadece 0-5 veya 0-10 veya 0-15 veya 0-20 alındıysa daha derin toprak yoksa burada sadece üst toprak tekstürü olacak. Eğer 0-20 ve 20-40 alındıysa, 0-20 üst tekstür 20-40 alt tekstür olacak. Eğer 0-30 tek örnek alındıysa burada da bu örnek hem üst tekstür hem alt tekstür olacak.

Yukarıda tüm varyosyanlara örnek yaptım diye düşündüm. Ben kafamdan bir formül kurgulayamadım. Sizlerden öneri mutlaka gelir. Şimdiden teşekkür ederim.

 

[pitchoute]

Merhaba, yedek alıp denedikten sonra sonucu paylaşabilir misiniz;

Sub ToprakAnalizi()
    Dim wsKaynak As Worksheet, wsHedef As Worksheet
    Dim dict As Object
    Dim i As Long, lastRow As Long
    Dim sondaNo As String, derinlik As String, buyne As String
    Dim ustBuyne As String, altBuyne As String
    Dim baslangic As Integer, bitis As Integer
    
    Set wsKaynak = ThisWorkbook.Sheets("Kaynak")
    Set wsHedef = ThisWorkbook.Sheets.Add(After:=wsKaynak)
    wsHedef.Name = "Sonuc"
    
    wsHedef.Range("A1:C1") = Array("Sonda No", "Üst Bünye", "Alt Bünye")
    
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = wsKaynak.Cells(wsKaynak.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        sondaNo = CStr(wsKaynak.Cells(i, 1).Value)
        derinlik = wsKaynak.Cells(i, 2).Value
        buyne = wsKaynak.Cells(i, 3).Value
        
        If buyne = "Bunu almayacak" Then GoTo SonrakiSatir
        baslangic = Split(derinlik, "-")(0)
        bitis = Split(derinlik, "-")(1)
        
        If baslangic < 20 And bitis > 0 Then
            If Not dict.Exists(sondaNo) Then dict.Add sondaNo, ""
            If baslangic = 0 And bitis > 20 Then bitis = 20
            ustBuyne = buyne
            If bitis >= 20 Then altBuyne = buyne
        End If
        
        If baslangic >= 20 Or (baslangic < 20 And bitis > 20) Then
            If Not dict.Exists(sondaNo) Then dict.Add sondaNo, ""
            altBuyne = buyne
        End If
        
        If dict.Exists(sondaNo) Then
            dict(sondaNo) = ustBuyne & "|" & altBuyne
        End If
        
SonrakiSatir:
    Next i
    Dim rowCount As Long: rowCount = 2
    Dim key As Variant, values As Variant
    
    For Each key In dict.keys
        values = Split(dict(key), "|")
        wsHedef.Cells(rowCount, 1) = key
        wsHedef.Cells(rowCount, 2) = values(0)
        wsHedef.Cells(rowCount, 3) = values(1)
        rowCount = rowCount + 1
    Next key
    
    wsHedef.Columns("A:C").AutoFit
    MsgBox "İşlem tamamlandı! Sonuçlar '" & wsHedef.Name & "' sayfasında.", vbInformation
End Sub