Damga(10) lu Hücrede Toplama

[leonadies]

Üstadlar Merhaba;

Çalışmamda bazı mecburiyetlerden ötürü tek bir hücrede var olan değerlerle toplama yaptırmam gerekiyor. Hücredeki formlar kesinlikle hep aynı;
%işaretine kadar isim
% ; arası toplam adeti gösteriyor. K1 hücresinde var olan bu yapıyı P: P sütununa klasik alt alta çıkartabilir miyiz?

 

[Necdet]

Merhaba

P1 e %10, P2 ye %20 .... diye mi gidecek?

 

[leonadies]

evet o şekilde

 

[Necdet]

Merhaba,

P sütununu %0 olarak özel hücre biçiminden biçimlendirin.

Sub Ayır()

    Dim d   As Variant, _
        i   As Long, _
        j   As Long, _
        k   As Integer, _
        l   As Integer
    
    For i = 1 To Cells(Rows.Count, "K").End(3).Row
        d = Split(Cells(i, "K"), ";")
        For k = 0 To UBound(d)
            l = InStr(d(k), "%")
             If l > 0 Then
                 j = j + 1
                 Cells(j, "P") = Right(d(k), Len(d(k)) - l) / 100
            End If
        Next k
        
    Next i
    
End Sub

 

[leonadies]

Üstadım öncelikle eline sağlık;
Sanırım ben yanlış anlamaya sebep verecek şekilde anlattım. istediğim şöyleydi. % işareti burada sadece ayraç. Biz toplam sayıları ayırmaya çalışıyoruz.

 

[leonadies]

Gerçi K2,K3,K4.... hücrelerinede aynı K1 Hücresindeki gibi bir giriş olursa bunları nasıl çözerim bilemedim.

 

[Necdet]

Merhaba,

Koddaki / 100 ü silin olsun bitsin

 

[leonadies]

İsimlerde lazım ama yoksa neyin ne olduğunu anlayamam ki

 

[Korhan Ayhan]

Alternatif;

Hız olarak avantaj sağlayabilir.

Option Explicit

Sub Verileri_Ayir()
    Dim Son As Long, Veri As Variant, X As Long, Metin As Variant
    Dim Liste As Variant, Y As Integer, Say As Long, Bul As Byte, Zaman As Double

    Zaman = Timer

    Range("O:P").Clear
    Son = Cells(Rows.Count, "K").End(3).Row
    Veri = Range("K1:K" & Son).Value
    
    ReDim Liste(1 To UBound(Veri) * 5, 1 To 2)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Metin = Split(Veri(X, 1), Chr(10))
            For Y = LBound(Metin) To UBound(Metin)
                Bul = InStr(1, Metin(Y), "%")
                If Bul > 0 Then
                    Say = Say + 1
                    Liste(Say, 1) = Split(Metin(Y), "%")(0)
                    Liste(Say, 2) = Replace(Split(Metin(Y), "%")(1), ";", "")
                End If
            Next
        End If
    Next
    
    Range("O1").Resize(Say, 2) = Liste

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[leonadies]

Teşekkürler @Korhan Ayhan tam istediğim gibi Ellerinize sağlık

 

[Necdet]

Merhaba,

Korhan bey noktayı koymuş,
Basit kodlarla örnek ve alternatif olması açısından kodları deneyiniz.

Sub Listele()

    Dim d   As Variant, _
        e   As Variant, _
        i   As Long, _
        j   As Long, _
        k   As Integer
        
    For i = 1 To Cells(Rows.Count, "K").End(3).Row
        d = Split(Cells(i, "K"), Chr(10))
        For k = 0 To UBound(d)
            j = j + 1
            e = Split(Replace(d(k), ";", ""), "%")
            Cells(j, "O") = e(0)
            Cells(j, "P") = e(1)
        Next k
    Next i
    
End Sub

 

[leonadies]

@Korhan Ayhan hocam buradaki (#9 nolu mesaj) makroda bir sorunla karşılaşıyorum. Muhtemelen örneği yerinde veremediğim için. (% işaretinden sonrası gramaj sayı değeri kabul edelim)
Kırmızı boya%1,25 (bunda sorun yok) toplam sonucu 1,25 olarak çıkıyor (Virgüllü çıkarıyor)
Kırmızı boya%1,2536 (bunda sorun var) toplam sonucu 125.36 olarak (noktalı çıkarıyor)

bu hatayı nasıl düzeltebiliriz ? Birde birebir isim örtüşenleri toplatma şansımız olur mu?

 

[Ali]

Formülle deneme yaptım. Oluyor mu diye.

Metinler için

=YERİNEKOY(YERİNEKOY(KIRP(PARÇAAL(YERİNEKOY(";"&$K$1;";";YİNELE(" ";255));SATIRSAY($R$1:R1)*255;255));DEĞİŞTİR(R1;1;MİN(MBUL({0;1;2;3;4;5;6;7;8;9};R1&"0123456789"))-1;"");"");"%";"")

Sayılar için

=DEĞİŞTİR(KIRP(PARÇAAL(YERİNEKOY(";"&$K$1;";";YİNELE(" ";255));SATIRSAY($R$1:R1)*255;255));1;MİN(MBUL({0;1;2;3;4;5;6;7;8;9};KIRP(PARÇAAL(YERİNEKOY(";"&$K$1;";";YİNELE(" ";255));SATIRSAY($R$1:R1)*255;255))&"0123456789"))-1;"")+0

 

[Korhan Ayhan]

Virgüllü sayılar için aşağıdaki kodu deneyiniz.

İkinci talebinizi anlamadım. Çünkü kodlarda herhangi bir toplama işlemi yapılmıyor.

Option Explicit

Sub Verileri_Ayir()
    Dim Son As Long, Veri As Variant, X As Long, Metin As Variant
    Dim Liste As Variant, Y As Integer, Say As Long, Bul As Byte, Zaman As Double

    Zaman = Timer

    Range("O:P").Clear
    Son = Cells(Rows.Count, "K").End(3).Row
    Veri = Range("K1:K" & Son).Value
    
    ReDim Liste(1 To UBound(Veri) * 5, 1 To 2)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Metin = Split(Veri(X, 1), Chr(10))
            For Y = LBound(Metin) To UBound(Metin)
                Bul = InStr(1, Metin(Y), "%")
                If Bul > 0 Then
                    Say = Say + 1
                    Liste(Say, 1) = Split(Metin(Y), "%")(0)
                    Liste(Say, 2) = Replace(Replace(Split(Metin(Y), "%")(1), ",", "."), ";", "")
                End If
            Next
        End If
    Next
    
    Range("O1").Resize(Say, 2) = Liste

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub