• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile en küçük ve en büyük değerler

Kod, sütun başlığını seçtiğinizde küçükten büyüğe sıralıyor.
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row <> 1 Then Exit Sub
If Target.Column = 1 Then Exit Sub
    With Sheets("Sayfa2")
    .[A2:c13].Clear
    .[A2:c13] = WorksheetFunction.Transpose(Sheets("Sayfa1").[c1:n3])
    .[A2:c13].Sort key1:=.Cells(2, Target.Column)
    End With
End Sub
 

Ekli dosyalar

sanırım sorunumu tam olarak anlatamadım.
her satır için en küçük değer bulunduğu satırın "O" sütununa, en küçük değerin verildiği ay yine bulunduğu satırın "P" sütununa , en küçük 2.değer bulunduğu satırın "R" sütununa yazılacak şekilde olması gerekiyor.
Artan veya azalan değer olarak bütün değerleri almak istemiyorum.
saygılarımla
 
arkdaşlar aşağıdaki kodlar sayesinde istediklerimin bir çoğunu yapıyorum fakat, en küçük değerlerin hangi aylara ait olduğnu ilgili satırın "P" ,"R" ve "T" sütunluarına yazdırmam gerekiyor. yardımcı olursanız memnun olurum. saygılarımla...


Sub doldur()
Set s1 = Sheets("sayfa1")
s1.Select
sat = s1.[b65536].End(3).Row
Range("o2:w" & sat).Select
Selection.ClearContents
For satir = 2 To sat
z = 1
20
birinci = WorksheetFunction.Small(Range(Cells(satir, 3), Cells(satir, 12)), z)
If birinci = 0 Then
z = z + 1
GoTo 20
End If
buyuk1 = WorksheetFunction.Large(Range(Cells(satir, 3), Cells(satir, 12)), 1)
buyuk2 = WorksheetFunction.Large(Range(Cells(satir, 3), Cells(satir, 12)), 2)
buyuk3 = WorksheetFunction.Large(Range(Cells(satir, 3), Cells(satir, 12)), 3)
ikinci = WorksheetFunction.Small(Range(Cells(satir, 3), Cells(satir, 12)), z + 1)
ucuncu = WorksheetFunction.Small(Range(Cells(satir, 3), Cells(satir, 12)), z + 2)
Range("o" & satir).Value = birinci
Range("q" & satir).Value = ikinci
Range("s" & satir).Value = ucuncu
Range("u" & satir).Value = buyuk1
Range("v" & satir).Value = buyuk2
Range("w" & satir).Value = buyuk3
Next satir
End Sub
 
Bu şekilde deneyin.
Kod: 
Sub test()
    With Sheets("Sayfa2")
    .[A2:c13].Clear
    .[A2:c13] = WorksheetFunction.Transpose(Sheets("Sayfa1").[c1:n3])
    For j = 2 To 3
    For i = 2 To 13
    If .Cells(i, j) = 0 Then .Cells(i, j) = ""
    Next
    .[A2:c13].Sort key1:=.Cells(2, j), Order1:=xlAscending
    Sayfa1.Cells(j, "o") = .Cells(2, j)
    Sayfa1.Cells(j, "q") = .Cells(3, j)
    Sayfa1.Cells(j, "s") = .Cells(4, j)
    Sayfa1.Cells(j, "p") = .[a2]
    Sayfa1.Cells(j, "r") = .[a3]
    Sayfa1.Cells(j, "t") = .[a4]
    .[A2:c13].Sort key1:=.Cells(2, j), Order1:=xlDescending
    Sayfa1.Cells(j, "u") = .Cells(2, j)
    Sayfa1.Cells(j, "v") = .Cells(3, j)
    Sayfa1.Cells(j, "w") = .Cells(4, j)
    MsgBox "İşlem tamam"
    Next
    End With
End Sub
 
hamitcan' Alıntı:
Bu şekilde deneyin.
Kod: 
Sub test()
    With Sheets("Sayfa2")
    .[A2:c13].Clear
    .[A2:c13] = WorksheetFunction.Transpose(Sheets("Sayfa1").[c1:n3])
    For j = 2 To 3
    For i = 2 To 13
    If .Cells(i, j) = 0 Then .Cells(i, j) = ""
    Next
    .[A2:c13].Sort key1:=.Cells(2, j), Order1:=xlAscending
    Sayfa1.Cells(j, "o") = .Cells(2, j)
    Sayfa1.Cells(j, "q") = .Cells(3, j)
    Sayfa1.Cells(j, "s") = .Cells(4, j)
    Sayfa1.Cells(j, "p") = .[a2]
    Sayfa1.Cells(j, "r") = .[a3]
    Sayfa1.Cells(j, "t") = .[a4]
    .[A2:c13].Sort key1:=.Cells(2, j), Order1:=xlDescending
    Sayfa1.Cells(j, "u") = .Cells(2, j)
    Sayfa1.Cells(j, "v") = .Cells(3, j)
    Sayfa1.Cells(j, "w") = .Cells(4, j)
    MsgBox "İşlem tamam"
    Next
    End With
End Sub
Genişletmek için tıkla ...

hamitcan hocam öncelikle ilgin için teşekkür ederim. verdiğim örnekte yaptıkarınız tam istediğim gibi. ama benim hatam olacak ki ben isim sayılarının 2 den fazla olduğunu belirtmemişim. verdiğim örnekte yer kapmasın diye sadece isim1 ve isim2 yazdım yani b kolonundaki veriler epeyce fazla. verdiğiniz örnek üzerinden yapmaya çalıştım fakat bir türlü başaramadım. saygılarımla...
 
Bir de böyle deneyin.
Kod: 
Sub test()
son = Sayfa1.[b65536].End(3).Row
    With Sheets("Sayfa2")
    .Range("A2:c" & son).Clear
    .Range("A2:c" & son) = WorksheetFunction.Transpose(Sheets("Sayfa1").Range("c1:n" & son))
    For j = 2 To son
    For i = 2 To 13
    If .Cells(i, j) = 0 Then .Cells(i, j) = ""
    Next
    .Range("A2:c" & son).Sort key1:=.Cells(2, j), Order1:=xlAscending
    Sayfa1.Cells(j, "o") = .Cells(2, j)
    Sayfa1.Cells(j, "q") = .Cells(3, j)
    Sayfa1.Cells(j, "s") = .Cells(4, j)
    Sayfa1.Cells(j, "p") = .[a2]
    Sayfa1.Cells(j, "r") = .[a3]
    Sayfa1.Cells(j, "t") = .[a4]
    .Range("A2:c" & son).Sort key1:=.Cells(2, j), Order1:=xlDescending
    Sayfa1.Cells(j, "u") = .Cells(2, j)
    Sayfa1.Cells(j, "v") = .Cells(3, j)
    Sayfa1.Cells(j, "w") = .Cells(4, j)
    MsgBox "İşlem tamam"
    Next
    End With
End Sub
 
hamitcan hocam ilgin için teşekkür ederim. kodlarından yararlanarak bir takım düzenlemeler yaptım ve işimi gördüm. düzenlediğim kodları aşağıda veriyorum. belki birilerine gerekebilir. tekrar teşekkürler...

Sub test1()
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
sat = s1.[b65536].End(3).Row
Sheets("sayfa1").Select
Range("o2:w" & sat).Select
Selection.ClearContents
Sheets("sayfa2").Select
Range("a1:z" & sat).Select
Selection.ClearContents
With Sheets("Sayfa2")
.Range(Cells(1, 1), Cells(13, sat)) = WorksheetFunction.Transpose(Sheets("sayfa1").Range("b1:n" & sat))
For j = 2 To sat
For i = 2 To 13
On Error Resume Next
If .Cells(i, j) = 0 Then .Cells(i, j) = ""
Next
.Range(Cells(2, 1), Cells(13, sat)).Sort Key1:=.Cells(2, j), Order1:=xlAscending
Sayfa1.Cells(j, "o") = .Cells(2, j)
Sayfa1.Cells(j, "p") = .[a2]
Sayfa1.Cells(j, "q") = .Cells(3, j)
Sayfa1.Cells(j, "r") = .[a3]
Sayfa1.Cells(j, "s") = .Cells(4, j)
Sayfa1.Cells(j, "t") = .[a4]
.Range(Cells(2, 1), Cells(13, sat)).Sort Key1:=.Cells(2, j), Order1:=xlDescending
Sayfa1.Cells(j, "u") = .Cells(2, j)
Sayfa1.Cells(j, "v") = .Cells(3, j)
Sayfa1.Cells(j, "w") = .Cells(4, j)
Next
End With
Sheets("sayfa1").Select
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst