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

hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
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ü
247621
 

Ekli dosyalar

D

DoğanD

Altın Üye
Katılım
22 Eylül 2023
Mesajlar
427
Excel Vers. ve Dili
Office 365 TR
Altın Üyelik Bitiş Tarihi
05-10-2028
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.
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
 
hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
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
Genişletmek için tıkla ...
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ı ?
 
D

DoğanD

Altın Üye
Katılım
22 Eylül 2023
Mesajlar
427
Excel Vers. ve Dili
Office 365 TR
Altın Üyelik Bitiş Tarihi
05-10-2028
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

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
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'
Genişletmek için tıkla ...
çok teşekkür ederim Doğan Bey
 
hadromer

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
Doğan Bey,
kodu modüle uygulayıp çalıştırınca
Sheets("Rapor").Delete
kısmında hata alıyorum
 
D

DoğanD

Altın Üye
Katılım
22 Eylül 2023
Mesajlar
427
Excel Vers. ve Dili
Office 365 TR
Altın Üyelik Bitiş Tarihi
05-10-2028
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

hadromer

Altın Üye
Katılım
23 Ekim 2015
Mesajlar
402
Excel Vers. ve Dili
LTSC Professional Plus 2021 64 Bit Türkçe
Altın Üyelik Bitiş Tarihi
26-04-2028
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
Genişletmek için tıkla ...
Çok teşekkür ederim şimdi çalıştı.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst