Sayı Sıralatarak Label'a yazma Hk.

[emre311]

Merhaba;
Aşağıdaki gibi Vba'da toplama işlemi yaptırmaktayım. Toplama işlemi bittikten sonra en büyükten en küçüğe sıralaratarak tek bir label'a yazdırmak istiyorum. Sonuç sıfır olanları labele yazdırmak istemiyorum. Yardım edecek arkadaşlara şimdiden teşekkürler . İyi çalışmalar.

Örnek:
h1 = WorksheetFunction.SumIf(ActiveSheet.Range("P"), "H1" Or "h1", ActiveSheet.Range("Q:Q")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("R:R"), "H1" Or "h1", ActiveSheet.Range("S:S")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("T:T"), "H1" Or "h1", ActiveSheet.Range("U:U")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("V:V"), "H1" Or "h1", ActiveSheet.Range("W:W"))

b6 = WorksheetFunction.SumIf(ActiveSheet.Range("P"), "B6" Or "b6", ActiveSheet.Range("Q:Q")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("R:R"), "B6" Or "b6", ActiveSheet.Range("S:S")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("T:T"), "B6" Or "b6", ActiveSheet.Range("U:U")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("V:V"), "B6" Or "b6", ActiveSheet.Range("W:W"))

b7 = WorksheetFunction.SumIf(ActiveSheet.Range("P"), "B7" Or "b7", ActiveSheet.Range("Q:Q")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("R:R"), "B7" Or "b7", ActiveSheet.Range("S:S")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("T:T"), "B7" Or "b7", ActiveSheet.Range("U:U")) + _
WorksheetFunction.SumIf(ActiveSheet.Range("V:V"), "B7" Or "b7", ActiveSheet.Range("W:W"))

' H1 > B6 > B7 durumunda aşağıdaki şekilde. Sıralama değişirse en büyük en başta veya biri 0 çıkarsa sonuç hiç yazılmayacak. Bu kodlar örnek, gerçekte daha fazla olduğundan tüm ihtimalleri yazarak yapamıyorum.

Label1.Caption = ("H1 = " & h1 & " dk" & ", " & B6 = " & b6 & " dk" & ", "B7 = " & b7 & " dk")

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kod yapısını kendi kodlarınıza uyarlarsınız.

DefDbl D: DefInt X

Sub Test()
    ReDim Liste(1 To 10)
   
    D_1 = 0
    Liste(1) = D_1
    D_2 = 4
    Liste(2) = D_2
    D_3 = 12
    Liste(3) = D_3
    D_4 = 65
    Liste(4) = D_4
    D_5 = 0
    Liste(5) = D_5
    D_6 = 25
    Liste(6) = D_6
    D_7 = 15
    Liste(7) = D_7
    D_8 = 3
    Liste(8) = D_8
    D_9 = 7
    Liste(9) = D_9
    D_10 = 100
    Liste(10) = D_10

    With VBA.CreateObject("System.Collections.ArrayList")
        For X = 1 To UBound(Liste)
            If Liste(X) <> 0 Then .Add "D_" & X & " " & Liste(X)
        Next
       
        .Sort
        .Reverse
       
        MsgBox Join(.ToArray(), ", ")
    End With
End Sub

 

[emre311]

Korhan bey;
Çok teşekkür ederim. "MsgBox Join(.ToArray(), ", ")" kodunda sadece rakamlar çıktı D_1 veya D_2 hangisine aitse çıkabilirmi. Birde mesaj kutusuna değilde UserForm1.Label20.Caption yazdırmak istiyorum nasıl yaparım. Kolay gelsin . İyi çalışmalar.

 

[emre311]

D_1 120 , D_2 18, D_3 10 gibi.

 

[Korhan Ayhan]

Önerdiğim kodu güncelledim.

Label'de sonucu görmek için önerdiğim kodu formunuzda uygun bir olaya yazmalısınız. Sonrasında aşağıdaki gibi kullanabilirsiniz.

UserForm1.Label20.Caption = Join(.ToArray(), ", ")

 

[emre311]

Çok teşekkür ederim Korhan bey.

 

[emre311]

Korhan bey aşağıdaki gibi uyarladım bir türlü Label20.Caption'a (Elma 15, Armut 12, Muz 10) gibi yazdıramadım. Kusura bakmayın yanlış anlattım sanırım size zahmet veriyorum.

ReDim Liste(1 To 4)
Elma = 15
Liste(1) = Elma
Ayva = 0
Liste(2) = Ayva
Muz = 10
Liste(3) = Muz
Armut = 12
Liste(4) = Armut

With VBA.CreateObject("System.Collections.ArrayList")
For X = 1 To UBound(Liste)
If Liste(X) <> 0 Then .Add "D-" & " " & Liste(X) & " dk"
Next

.Sort
.Reverse

UserForm1.Label24.Caption = Join(.ToArray(), ", ")

Çıktı = Elma 15, Armut 12, Muz 10 (Ayva 0 olduğundan yazmayacak diğerleri büyükten küçüğe sıralanacak)

 

[Korhan Ayhan]

Dikkat ettiyseniz benim kullandığım tüm değişkenler "D_" ile başlıyor.

Döngü içinde de aşağıdaki gibi kullanmıştım. Yani kodu kısaltmak adına bir sistem uyguladım.

If Liste(X) <> 0 Then .Add "D_" & X & " " & Liste(X)

Sizin gibi her ürün için ayrı değişken kullanırsanız o zaman döngü kullanmanın bir esprisi kalmıyor.

 

[Korhan Ayhan]

Tabi bu arada sayıların yanına metinsel ifade eklediğimiz için sıralama hatası oluştu. Size başka bir kod önereceğim.

 

[Korhan Ayhan]

Bu kodu deneyiniz.

Option Explicit
Option Base 1

Private Sub CommandButton1_Click()
    Dim Malzeme As Variant, Miktar As Variant
    Dim X As Byte, Uzunluk As Variant, Metin As Variant
    
    Malzeme = Array("Elma", "Ayva", "Muz", "Armut", "Avokado", "Çilek", "Dut", "Üzüm", "İncir", "Karpuz")
    Miktar = Array(15, 0, 10, 12, 25, 7, 0, 8, 5, 350)
    
    Uzunluk = WorksheetFunction.Max(Miktar)
    Uzunluk = Len(Uzunluk)
    
    ReDim Liste(1 To 10)
    
    With VBA.CreateObject("System.Collections.ArrayList")
        For X = 1 To UBound(Miktar)
            If Miktar(X) <> 0 Then
                .Add WF.Rept("0", Uzunluk - Len(Miktar(X))) & Miktar(X) & " " & Malzeme(X)
            End If
        Next
        
        .Sort
        .Reverse
        Metin = .ToArray()

        With VBA.CreateObject("VBScript.RegExp")
            .Global = True
            .Pattern = "^[0]*"
            For X = 0 To UBound(Metin)
                Metin(X) = .Replace(Metin(X), "")
            Next
        End With
    End With
    
    Me.Label1.Caption = Join(Metin, ", ")
End Sub

 

[Korhan Ayhan]

Bu da ADO ile alternatif...

Not : Haluk beyin daha önce forumda paylaştığı kodlardan faydalandım. Link

Option Explicit

Private Sub CommandButton1_Click()
    Dim Material As Variant, Quantity As Variant, My_Recordset As Object
    Dim X As Byte, My_List As Variant, Sorted_List As Variant, Count As Byte
 
    Material = Array("Elma", "Ayva", "Muz", "Armut", "Avokado", "Çilek", "Dut", "Üzüm", "İncir", "Karpuz")
    Quantity = Array(15, 0, 10, 12, 25, 7, 0, 8, 5, 350)
 
    Set My_Recordset = VBA.CreateObject("AdoDB.Recordset")
 
    With My_Recordset
        .Fields.Append "Field_1", 129, 255
        .Fields.Append "Field_2", 5
        .Open
        For X = LBound(Material) To UBound(Material)
            .AddNew
            .Fields("Field_1").Value = Material(X)
            .Fields("Field_2").Value = Quantity(X)
        Next
        .Update
        .Sort = "Field_2 Desc"
        My_List = .GetRows()
    End With
 
    ReDim Sorted_List(0 To 0)
 
    For X = 0 To UBound(My_List, 2)
        If My_List(1, X) <> 0 Then
            ReDim Preserve Sorted_List(0 To Count)
            Sorted_List(X) = Trim(My_List(0, X)) & " " & My_List(1, X)
            Count = Count + 1
        End If
    Next
 
    Me.Label1.Caption = Join(Sorted_List, ", ")
 
    My_Recordset.Close
 
    Erase My_List
    Set My_Recordset = Nothing
End Sub

 

[emre311]

Çok teşekkür ederim Korhan Bey . Kolay gelsin iyi çalışmalar.

 

[veyselemre]

Merhaba, Korhan Beyin 11nolu mesajda vermiş olduğu kodun biraz kısaltılmış hali.

Private Sub CommandButton1_Click()
    Dim Material As Variant, Quantity As Variant
    Dim X As Long
 
    Material = Array("Elma", "Ayva", "Muz", "Armut", "Avokado", "Çilek", "Dut", "Üzüm", "İncir", "Karpuz")
    Quantity = Array(15, 0, 10, 12, 25, 7, 0, 8, 5, 350)
 
    With VBA.CreateObject("AdoDB.Recordset")
        .Fields.Append "Field_0", 200, 255
        .Fields.Append "Field_1", 200, 255
        .Fields.Append "Field_2", 5
        .Open
        For X = LBound(Material) To UBound(Material)
            If Quantity(X) > 0 Then 'Filter kullanılacaksa bu if kontrolü kaldırılabilir. Bu şekilde daha mantıklı.
                .AddNew
                .Fields("Field_0").Value = Quantity(X) & " " & Material(X)
                .Fields("Field_1").Value = Material(X)
                .Fields("Field_2").Value = Quantity(X)
            End If
        Next
        .Update
        '.Filter = "Field_2>0"
        .Sort = "Field_2 Desc"

        Me.Label1.Caption = Join(Application.Index(.GetRows(, , "Field_0"), 0), ", ")
        .Close
    End With
 
End Sub