Hücre içerisindeki değere göre yeniden sıralama

hadromer · 9 Kasım 2023

Merhaba,
Data isimli ekran görüntüsünde olduğu gibi ayrı sayfalarda bulunan veri setlerim var. Sütun ve satır sayıları değişkenlik göstermekte.
Ben bu verileri bazı kurala göre B sütunundaki değerlerini eşleştirip sıralamak istiyorum.
İstediğim formata ait bir ekran görüntüsü de ekledim.
Yani 1. Satırda yer alan başlıkları 3. sütundan itibaren aşağıdaki kurala göre sıralamak istiyorum.
Örneğin ;
C2 hücresinde "amo" ifadesi var. amo, A2'de yer alan ALL'da 6 karşılığını almış. Bu yüzden amo'nun ALL'daki PO4b değeri 30.0
Bir başka örnek ;
N2 hücresinde cyso var. cyso N8'de 10 değerini almış. Bu değerin karşılık geldiği A sütunundaki ifade HaD (A8). cyso, HaD'da 10 değerini almış. Yani cyso HaD'da bir değeri olduğu için Bcyso'nun HaD'daki PO4b değerini yazacağız. 28.1

yukarıdaki iki örneğin excel görüntüsü böyle olacak;

Code

Sampling

Percent

PO4b

amo

ALL

6

30

cyso

HaD

10

28.1

Data Ekran Görüntüsü

DoğanD · 10 Kasım 2023

Merhaba,

Aşağıdaki gibi bir kod yazdım. Fakat satır bazında tekrar eden verileriniz var ve terimlerin ne ifade ettiğini anlamadığım için yorumlayamadım. Sonuç resimdeki gibi çıkıyor ve ne kadar işinize yarar bilemedim. Biraz daha detaylandırabilirseniz sonuca ulaşırız diye düşünüyorum. Data dosyasında boşb bir modüle yazıp çalıştırın lütfen.

Kod:

Sub dd()
Application.DisplayAlerts = False
Sheets("Rapor").Delete
Application.DisplayAlerts = True
Dim i, y, ss As Integer
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Rapor"
    Sheets("Rapor").Range("A1") = "Code"
    Sheets("Rapor").Range("b1") = "Sampling"
    Sheets("Rapor").Range("c1") = "Percent"
    Sheets("Rapor").Range("d1") = "PO4b"

ss = 2
For i = 2 To Sayfa2.Range("A" & Rows.Count).End(xlUp).Row
    For y = 3 To Sayfa2.UsedRange.Columns.Count
    If Sayfa2.Cells(i, y) > 0 Then
Sheets("Rapor").Cells(ss, 1) = Sayfa2.Cells(1, y)
Sheets("Rapor").Cells(ss, 2) = Sayfa2.Cells(i, 1)
Sheets("Rapor").Cells(ss, 3) = Sayfa2.Cells(i, y)
Sheets("Rapor").Cells(ss, 4) = Sayfa2.Cells(i, 2)
ss = ss + 1
    End If
    Next y
Next i


    Range("A1:D" & ss).Select
  '  Range("C10").Activate
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add2 Key:=Range("A2:A" & ss) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add2 Key:=Range("B2:B" & ss) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Rapor").Sort
        .SetRange Range("A1:D" & ss)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

hadromer · 10 Kasım 2023

DoğanD' Alıntı:

Merhaba,

Aşağıdaki gibi bir kod yazdım. Fakat satır bazında tekrar eden verileriniz var ve terimlerin ne ifade ettiğini anlamadığım için yorumlayamadım. Sonuç resimdeki gibi çıkıyor ve ne kadar işinize yarar bilemedim. Biraz daha detaylandırabilirseniz sonuca ulaşırız diye düşünüyorum. Data dosyasında boşb bir modüle yazıp çalıştırın lütfen.
Ekli dosyayı görüntüle 247630

Kod:

Sub dd()
Application.DisplayAlerts = False
Sheets("Rapor").Delete
Application.DisplayAlerts = True
Dim i, y, ss As Integer
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Rapor"
    Sheets("Rapor").Range("A1") = "Code"
    Sheets("Rapor").Range("b1") = "Sampling"
    Sheets("Rapor").Range("c1") = "Percent"
    Sheets("Rapor").Range("d1") = "PO4b"

ss = 2
For i = 2 To Sayfa2.Range("A" & Rows.Count).End(xlUp).Row
    For y = 3 To Sayfa2.UsedRange.Columns.Count
    If Sayfa2.Cells(i, y) > 0 Then
Sheets("Rapor").Cells(ss, 1) = Sayfa2.Cells(1, y)
Sheets("Rapor").Cells(ss, 2) = Sayfa2.Cells(i, 1)
Sheets("Rapor").Cells(ss, 3) = Sayfa2.Cells(i, y)
Sheets("Rapor").Cells(ss, 4) = Sayfa2.Cells(i, 2)
ss = ss + 1
    End If
    Next y
Next i


    Range("A1:D" & ss).Select
  '  Range("C10").Activate
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add2 Key:=Range("A2:A" & ss) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add2 Key:=Range("B2:B" & ss) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Rapor").Sort
        .SetRange Range("A1:D" & ss)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Merhaba,
çok teşekkür ederim. Benim detayları eksik ifade etmeme rağmen tam istediğim gibi bir sonuç elde etmişsiniz. Çok mutlu oldum. Elinize sağlık

Bir soru sormak istiyorum. Sütun sayılarım değişkenlik gösterebiliyor. Sütun sayısı artarsa veya azalırsa yine aynı şekilde çalışır mı ?

DoğanD · 10 Kasım 2023

Merhaba,

İşe yaradığına sevindim. Aşağıdaki kodlar satır ve sütun sayılarını her seferinde kontrol ediyor ve dolu olanların tümü için işlem yapıyor. Dilediğiniz gibi test edebilirsiniz.

Kod:

For i = 2 To Sayfa2.Range("A" & Rows.Count).End(xlUp).Row 'Satır'
    For y = 3 To Sayfa2.UsedRange.Columns.Count 'Sütun'

hadromer · 10 Kasım 2023

DoğanD' Alıntı:
Merhaba,

İşe yaradığına sevindim. Aşağıdaki kodlar satır ve sütun sayılarını her seferinde kontrol ediyor ve dolu olanların tümü için işlem yapıyor. Dilediğiniz gibi test edebilirsiniz.

Kod:

For i = 2 To Sayfa2.Range("A" & Rows.Count).End(xlUp).Row 'Satır' For y = 3 To Sayfa2.UsedRange.Columns.Count 'Sütun'

çok teşekkür ederim Doğan Bey

hadromer · 10 Kasım 2023

Doğan Bey,
kodu modüle uygulayıp çalıştırınca
Sheets("Rapor").Delete
kısmında hata alıyorum

DoğanD · 10 Kasım 2023

Merhaba,

Sonuçtan emin olamadığım için tamamlamamışım orayı. Kodu aşağıdaki gibi revize ettim.

Kod:

Sub dd()

    Dim sayf As Integer
    For sayf = 1 To Worksheets.Count
        If Worksheets(sayf).Name = "Rapor" Then
            Application.DisplayAlerts = False
            Sheets("Rapor").Delete
            Application.DisplayAlerts = True
        End If
    Next sayf
Dim i, y, ss As Integer
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Rapor"
    Sheets("Rapor").Range("A1") = "Code"
    Sheets("Rapor").Range("b1") = "Sampling"
    Sheets("Rapor").Range("c1") = "Percent"
    Sheets("Rapor").Range("d1") = "PO4b"
ss = 2

For i = 2 To Sayfa1.Range("A" & Rows.Count).End(xlUp).Row
    For y = 3 To Sayfa1.UsedRange.Columns.Count
    If Sayfa1.Cells(i, y) > 0 Then
Sheets("Rapor").Cells(ss, 1) = Sayfa1.Cells(1, y)
Sheets("Rapor").Cells(ss, 2) = Sayfa1.Cells(i, 1)
Sheets("Rapor").Cells(ss, 3) = Sayfa1.Cells(i, y)
Sheets("Rapor").Cells(ss, 4) = Sayfa1.Cells(i, 2)
ss = ss + 1
    End If
    Next y
Next i

    Range("A1:D" & ss).Select
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add2 Key:=Range("A2:A" & ss) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add2 Key:=Range("B2:B" & ss) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Rapor").Sort
        .SetRange Range("A1:D" & ss)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

hadromer · 10 Kasım 2023

DoğanD' Alıntı:

Merhaba,

Sonuçtan emin olamadığım için tamamlamamışım orayı. Kodu aşağıdaki gibi revize ettim.

Kod:

Sub dd()

    Dim sayf As Integer
    For sayf = 1 To Worksheets.Count
        If Worksheets(sayf).Name = "Rapor" Then
            Application.DisplayAlerts = False
            Sheets("Rapor").Delete
            Application.DisplayAlerts = True
        End If
    Next sayf
Dim i, y, ss As Integer
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "Rapor"
    Sheets("Rapor").Range("A1") = "Code"
    Sheets("Rapor").Range("b1") = "Sampling"
    Sheets("Rapor").Range("c1") = "Percent"
    Sheets("Rapor").Range("d1") = "PO4b"
ss = 2

For i = 2 To Sayfa1.Range("A" & Rows.Count).End(xlUp).Row
    For y = 3 To Sayfa1.UsedRange.Columns.Count
    If Sayfa1.Cells(i, y) > 0 Then
Sheets("Rapor").Cells(ss, 1) = Sayfa1.Cells(1, y)
Sheets("Rapor").Cells(ss, 2) = Sayfa1.Cells(i, 1)
Sheets("Rapor").Cells(ss, 3) = Sayfa1.Cells(i, y)
Sheets("Rapor").Cells(ss, 4) = Sayfa1.Cells(i, 2)
ss = ss + 1
    End If
    Next y
Next i

    Range("A1:D" & ss).Select
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add2 Key:=Range("A2:A" & ss) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Rapor").Sort.SortFields.Add2 Key:=Range("B2:B" & ss) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Rapor").Sort
        .SetRange Range("A1:D" & ss)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Çok teşekkür ederim şimdi çalıştı.

Hücre içerisindeki değere göre yeniden sıralama

Ekli dosyalar