• DİKKAT

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

hücre içerisinde farklı nesneleri toplama?

Sn. Halit Bey, 31 olan PANAX toplamını 17 olarak veriyor. Bilgilerinize.
 
Sn. Halit Bey, 31 olan PANAX toplamını 17 olarak veriyor. Bilgilerinize.

Ben o zaman konuyu yanlış anlamışım söylediğiniz doğrultuda 20 nolu mesajdaki kodu düzelttim.

Ayrıca buraya farklı bir kod ekliyorum.


Kod:
Option Explicit
Sub aktar()
Application.ScreenUpdating = False
Dim aranan, aranan1, adres, sat, i, a, j, s, X, r, yer, t
sat = 2
Columns("J:O").ClearContents
aranan = "+"
For r = 2 To Cells(Rows.Count, "g").End(3).Row
adres = Cells(r, 7).Value & aranan
a = InStr(Trim(adres), aranan)
For j = 1 To Len(adres)
i = InStr(j, adres, aranan, vbTextCompare)
If i > 0 Then
yer = WorksheetFunction.Trim(Mid(Cells(r, "g").Value, j, i - j))
 
For t = 1 To Len(yer)
If IsNumeric(Mid(yer, 1, t)) = False Then
Cells(sat, "N").Value = WorksheetFunction.Trim(Mid(yer, t, Len(yer)))
Cells(sat, "M").Value = WorksheetFunction.Trim(Mid(yer, 1, t - 1))
Exit For
End If
Next
If Cells(sat, "M").Value = "" Then
Cells(sat, "o").Value = 1
End If
sat = sat + 1
j = i
End If
Next
Next
Set j = CreateObject("Scripting.Dictionary")
For Each X In Range("n2:n" & Cells(Rows.Count, "n").End(3).Row)
If X.Value <> "" Then
If Not j.exists(LCase(X.Value)) Then
j.Add LCase(X.Value), Nothing
s = s + 1
Cells(s + 1, "j").Value = X.Value
Cells(s + 1, "l").Value = WorksheetFunction.SumIf(Range("n:n"), Cells(s + 1, "j").Value, Range("m:m"))
If Cells(s + 1, "l").Value = 0 Then
Cells(s + 1, "l").Value = ""
End If
Cells(s + 1, "k").Value = WorksheetFunction.SumIf(Range("n:n"), Cells(s + 1, "j").Value, Range("o:o"))
If Cells(s + 1, "K").Value = 0 Then
Cells(s + 1, "K").Value = ""
End If

End If
End If
Next X
Columns("M:O").ClearContents
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub
 

Ekli dosyalar

Sn. Halit hocam, sonuçta herhangi bir değişiklik olmadı, sonuç PANAX toplamı yine 17 olarak veriyor, tabii diğerlerinide eksik veriyor. PANAX 17 ayrı hücrede yazılı olduğunu değil de PANAX ın başında yazan rakamların toplamı olan 31 sayısını vermesi gerektiğini anlamıştım. Aslında konu sn. Eminecik adlı arkadaşımızın sorusuydu, ben Korhan hocamın verdiği cevaptan bu sayıların toplanması gerektiğini anlıyorum. Bu şekilde kodlarda düzeltme yaparsanız sn. eminecik'in sorusunun cevabı verilmiş olacak. Bende merak ettiğimden konuyu takip ediyordum. Saygılarımla. Tahsin.
 
Son düzenleme:
Sn. Halit hocam, sonuçta herhangi bir değişiklik olmadı, sonuç PANAX toplamı yine 17 olarak veriyor, tabii diğerlerinide eksik veriyor. PANAX 17 ayrı hücrede yazılı olduğunu değil de PANAX ın başında yazan rakamların toplamı olan 31 sayısını vermesi gerektiğini anlamıştım. Aslında konu sn. Eminecik adlı arkadaşımızın sorusuydu, ben Korhan hocamın verdiği cevaptan bu sayıların toplanması gerektiğini anlıyorum. Bu şekilde kodlarda düzeltme yaparsanız sn. eminecik'in sorusunun cevabı verilmiş olacak. Bende merak ettiğimden konuyu takip ediyordum. Saygılarımla. Tahsin.

Ben dosyayı değil kodları düzeltmiştim 22 nolu mesaja ekledim.
 
Sn. halit hocam şimdi farkettim. k sutunundaki toplamlara dikkat etmişim. evet şimdi olmuş, elinize sağlık. Bu bizim içinde güzel bir arşiv oldu. Çok teşekkürler. Saygılar.
 
Son düzenleme:
Sn. halit hocam şimdi farkettim. k sutunundaki toplamlara dikkat etmişim. evet şimdi olmuş, elinize sağlık. Bu bizim içinde güzel bir arşiv oldu. Çok teşekkürler. Saygılar.

K ve L sutünunlarına her iki duruma göre veriler geliyor.

İyi çalışmalar
 
Basit bir cetvel yapmayı planlarken konu öyle bir hale geldiki, inanın beklentilerimin katbekat ötesinde oldu. Değerli Halit Bey ve Tahsin Bey başta Korhan Bey olmak üzre katkılarınızdan ötürü çok teşekkür ederim. Halit Bey, sizin çalışmanızı da inceledim. Sayfada formül olmaması kullanım açısından çok daha rahat olmuş. Buna bağlı olarak yazım hatalarını da düzeltiyor. Yani bitişik yazmak ya da büyük harf küçük har gözetmeksizin yazabiliyorsunuz. Çok mükemmel oldu...

Burada M ve N sütünlarında aktarılan veriler anlamsız gibi olmuş. Yani onların olması zaruri ise kalsın. Ancak benim açımdan bir fonksiyon teşkil etmiyor. Ancak bir ufak detay varki beni en başta düşündüren konu idi. Çok eski dosyalarımızda adet belirtmeksizin yazılan adetler var. Yani her hangi bir adrese 1 adet panax gönderilecekse, buna adet belirtmeksizin sadece "panax" denmiş. Bu durumda "L" sütünunda toplama olmuyor. Ben bunu "K" sütünunda hesaplandığını gördüm. Lakin bu seferde adet belirtilen her hangi bir ürünü de topladığından doğru sonuca ulaşmak mümkün değil. Şayet olursa, uzun lafın kısası; "K" sütunu sadece adet belirtilmeyenleri toplayabilir mi?

Saygılarımla...


Edit: Tahsin bey, konuyu doğru anlamışsınız. Ayrıca teşekkür ederim.
 
Ekli dosyayı test ediniz

sn. eminecik, başında sayısal değer bulunmayan ürünlerin 1 adet olduğu kabul edilerek toplanmasını istediğinizi varsayarak, sn. Halit hocamın yapmış olduğu dosyaya (kodlarından faydalanarak) o sutununa değerleri taşıyıp boş olan ürünleri 1 adet olarak toplatılarak yapmış olduğum dosya ektedir. Test ederek sonucu bildirirseniz sevinirim.
 

Ekli dosyalar

kodların birleştirilmiş şekli

Sn. halit hocamın yazmış olduğu kodlara sizin istemiş olduğunuz şekilde olmasını sağlayan kodların ilave edilmiş hali. Belki Halit hocam daha güzel bir şekle getirebilir.
 

Ekli dosyalar

Merhaba,

Önerdiğim fonksiyonu aşağıdaki şekilde değiştirip deneyiniz.

Kod:
Function AYIR_TOPLA(Veri As Range, Kriter As Range)
    Dim Hücre As Range
    Dim RegExp As Object
    Dim Data_1 As String
    Dim X As Integer
    Dim Yeni_Data As String
    
    Application.Volatile True
    
    If Kriter = "" Then Exit Function
    
    Set RegExp = CreateObject("VBscript.RegExp")
    RegExp.Pattern = "\d"
    RegExp.Global = True
    
    For Each Hücre In Veri
        Data_1 = Trim(Replace(Hücre.Text, " ", ""))
        If InStr(1, Data_1, "+") = 0 Then
            If InStr(1, UCase(Replace(Replace(Data_1, "i", "İ"), "ı", "I")), _
                UCase(Replace(Replace(Kriter, "i", "İ"), "ı", "I")), vbTextCompare) > 0 Then
                If Evaluate("=UPPER(""" & Data_1 & """)") = Evaluate("=UPPER(""" & Kriter & """)") Then
                    AYIR_TOPLA = AYIR_TOPLA + 1
                Else
                    AYIR_TOPLA = AYIR_TOPLA + Val(Trim(Replace(UCase(Replace(Replace(Data_1, "i", "İ"), "ı", "I")), _
                                 UCase(Replace(Replace(Kriter, "i", "İ"), "ı", "I")), "", , , vbTextCompare)))
                End If
            End If
        Else
            Data_2 = Split(Data_1, "+")
            For X = 0 To UBound(Data_2)
                Yeni_Data = Replace(UCase(Replace(Replace(Data_2(X), "i", "İ"), "ı", "I")), _
                            UCase(Replace(Replace(Kriter, "i", "İ"), "ı", "I")), "", , , vbTextCompare)
                If Yeni_Data = "" Then
                    AYIR_TOPLA = AYIR_TOPLA + 1
                ElseIf RegExp.Replace(Yeni_Data, "") = "" Then
                    AYIR_TOPLA = AYIR_TOPLA + Val(Yeni_Data)
                End If
            Next
        End If
    Next
    
    Set RegExp = Nothing
End Function
 
22 nolu mesajdaki kodu ve dosyayı güncelledim.
İlave yaptığım yerleri kırmızı renkle belirttim.
 
Sn. Halit hocam ve Korhan hocam sayenizde çok güzel kodlar ve fonksiyonlar öğreniyoruz, her ikinize de ayrı ayrı teşekkür ediyorum, ayrıca sn. eminecik kardeşe de böylesine güzel bir konu açtığı için teşekkürler. Saygılar.
 
sn. eminecik, başında sayısal değer bulunmayan ürünlerin 1 adet olduğu kabul edilerek toplanmasını istediğinizi varsayarak, sn. Halit hocamın yapmış olduğu dosyaya (kodlarından faydalanarak) o sutununa değerleri taşıyıp boş olan ürünleri 1 adet olarak toplatılarak yapmış olduğum dosya ektedir. Test ederek sonucu bildirirseniz sevinirim.




Merhaba,

Önerdiğim fonksiyonu aşağıdaki şekilde değiştirip deneyiniz.

Kod:
Function AYIR_TOPLA(Veri As Range, Kriter As Range)
    Dim Hücre As Range
    Dim RegExp As Object
    Dim Data_1 As String
    Dim X As Integer
    Dim Yeni_Data As String
    
    Application.Volatile True
    
    If Kriter = "" Then Exit Function
    
    Set RegExp = CreateObject("VBscript.RegExp")
    RegExp.Pattern = "\d"
    RegExp.Global = True
    
    For Each Hücre In Veri
        Data_1 = Trim(Replace(Hücre.Text, " ", ""))
        If InStr(1, Data_1, "+") = 0 Then
            If InStr(1, Data_1, Kriter, vbTextCompare) > 0 Then
                If Evaluate("=UPPER(""" & Data_1 & """)") = Evaluate("=UPPER(""" & Kriter & """)") Then
                    AYIR_TOPLA = AYIR_TOPLA + 1
                Else
                    AYIR_TOPLA = AYIR_TOPLA + Val(Trim(Replace(Data_1, Kriter, "", , , vbTextCompare)))
                End If
            End If
        Else
            Data_2 = Split(Data_1, "+")
            For X = 0 To UBound(Data_2)
                Yeni_Data = Replace(Data_2(X), Kriter, "", , , vbTextCompare)
                If Yeni_Data = "" Then
                    AYIR_TOPLA = AYIR_TOPLA + 1
                ElseIf RegExp.Replace(Yeni_Data, "") = "" Then
                    AYIR_TOPLA = AYIR_TOPLA + Val(Yeni_Data)
                End If
            Next
        End If
    Next
    
    Set RegExp = Nothing
End Function

Ben o zaman konuyu yanlış anlamışım söylediğiniz doğrultuda 20 nolu mesajdaki kodu düzelttim.

Ayrıca buraya farklı bir kod ekliyorum.

Kod:
Option Explicit
Sub aktar()
Application.ScreenUpdating = False
Dim aranan, adres, sat, i, a, j, s, X, r, yer, t
sat = 2
Columns("J:N").ClearContents
aranan = "+"
For r = 2 To Cells(Rows.Count, "g").End(3).Row
adres = Cells(r, 7).Value & aranan
a = InStr(Trim(adres), aranan)
For j = 1 To Len(adres)
i = InStr(j, adres, aranan, vbTextCompare)
If i > 0 Then
yer = WorksheetFunction.Trim(Mid(Cells(r, "g").Value, j, i - j))
 
For t = 1 To Len(yer)
If IsNumeric(Mid(yer, 1, t)) = False Then
Cells(sat, "N").Value = WorksheetFunction.Trim(Mid(yer, t, Len(yer)))
Cells(sat, "M").Value = WorksheetFunction.Trim(Mid(yer, 1, t - 1))
Exit For
End If
Next
[COLOR=red]If Cells(sat, "M").Value = "" Then
Cells(sat, "M").Value = 1
End If[/COLOR]
sat = sat + 1
j = i
End If
Next
Next
Set j = CreateObject("Scripting.Dictionary")
For Each X In Range("n2:n" & Cells(Rows.Count, "n").End(3).Row)
If UCase(X.Value) <> "" Then
If Not j.exists(UCase(X.Value)) Then
j.Add UCase(X.Value), Nothing
s = s + 1
Cells(s + 1, "j").Value = UCase(X.Value)
Cells(s + 1, "k").Value = WorksheetFunction.CountIf(Range("n:n"), Cells(s + 1, "j").Value)
Cells(s + 1, "l").Value = WorksheetFunction.SumIf(Range("n:n"), Cells(s + 1, "j").Value, Range("m:m"))
End If
End If
Next X
[COLOR=red]Columns("M:N").ClearContents[/COLOR]
Application.ScreenUpdating = True

MsgBox "işlem tamam"
End Sub

Gerek Korhan Bey gerekse Halit Bey, emeğinize bilginize sağlık. Bu haliyle her iki çalışma da işimi görür. Ancak iki husus var belirtmeden geçemeyeceğim. Öncelikle Halit Bey'in çalışmasında "K" ve "L" sütunları aynı işlevi yapıyor. Yani veri öncesinde bulunan rakam olsun ya da olmasın aynı toplamı sunuyor. "K" sütununda adet belirtilmeyen "L" sütununda adet belirtilen toplanırsa çok daha iyi olur.

Korhan Bey, sizin çalışmanız doğru sonucu formül vasıtası ile veriyor. Aradığım ve istediğim bu şekildeydi. Elleriniz dert görmesin.

Her iki çalışmada ortak bir sorun var. Eğer "İ" ya da "i" harfi içeren değer varsa farklı değerlermiş gibi algılanıyor. Sanırım türkçe karakter sorunu. Buna bir çözüm bulunabilir mi?
 
Son düzenleme:
Merhaba,

#30 nolu mesajımdaki fonksiyonu "i-İ" harflerini algılayacak şekilde düzenledim. Tekrar denermisiniz.
 
Gerek Korhan Bey gerekse Halit Bey, emeğinize bilginize sağlık. Bu haliyle her iki çalışma da işimi görür. Ancak iki husus var belirtmeden geçemeyeceğim. Öncelikle Halit Bey'in çalışmasında "K" ve "L" sütunları aynı işlevi yapıyor. Yani veri öncesinde bulunan rakam olsun ya da olmasın aynı toplamı sunuyor. "K" sütununda adet belirtilmeyen "L" sütununda adet belirtilen toplanırsa çok daha iyi olur.

Korhan Bey, sizin çalışmanız doğru sonucu formül vasıtası ile veriyor. Aradığım ve istediğim bu şekildeydi. Elleriniz dert görmesin.

Her iki çalışmada ortak bir sorun var. Eğer "İ" ya da "i" harfi içeren değer varsa farklı değerlermiş gibi algılanıyor. Sanırım türkçe karakter sorunu. Buna bir çözüm bulunabilir mi?

Söylediklerinizi anladığım kadarıyla yapmaya çalıştım 22 nolu mesajdaki kodu güncelledim.
 
22 nolu mesajdaki kodu yeniden güncelledim.
 
Merhaba,

#30 nolu mesajımdaki fonksiyonu "i-İ" harflerini algılayacak şekilde düzenledim. Tekrar denermisiniz.

Denedim hocam. Tüm Türkçe karekter içeren harflerle de denedim. Şu an kusursuz oldu. Allah razı olsun...

Söylediklerinizi anladığım kadarıyla yapmaya çalıştım 22 nolu mesajdaki kodu güncelledim.

Sanırım bir üstteki mesajımda belirttiğim Türkçe karakter sorunu, "Her iki çalışmada ortak bir sorun var." şeklindeydi. Gözden kaçmış olacak. Türkçe karekter sorunu dışında her şey mükemmel. İstediğim gibi kusursuz. Lakin "REİSHİ" ve "reishi" yazılarını farklı algılıyor. Ayrı ayrı topluyor. Hatta diğer Türkçe karakterleri denedim. Onlarda bir sorun yok. Sadece "i" ve "İ" de sorun oluyor. Eğer düzelebilirse çok makbule geçer. Çünkü bu çalışmayı da kullanmak istiyorum.

Saygılarımla...
 
Denedim hocam. Tüm Türkçe karekter içeren harflerle de denedim. Şu an kusursuz oldu. Allah razı olsun...



Sanırım bir üstteki mesajımda belirttiğim Türkçe karakter sorunu, "Her iki çalışmada ortak bir sorun var." şeklindeydi. Gözden kaçmış olacak. Türkçe karekter sorunu dışında her şey mükemmel. İstediğim gibi kusursuz. Lakin "REİSHİ" ve "reishi" yazılarını farklı algılıyor. Ayrı ayrı topluyor. Hatta diğer Türkçe karakterleri denedim. Onlarda bir sorun yok. Sadece "i" ve "İ" de sorun oluyor. Eğer düzelebilirse çok makbule geçer. Çünkü bu çalışmayı da kullanmak istiyorum.

Saygılarımla...

Kod

Kod:
Option Explicit
Sub aktar()
Application.ScreenUpdating = False
Dim aranan, aranan1, adres, sat, i, a, j, s, X, r, yer, t
sat = 2
Columns("[COLOR=Red]J:O[/COLOR]").ClearContents
aranan = "+"
For r = 2 To Cells(Rows.Count, "[COLOR=Red]g[/COLOR]").End(3).Row
adres = Cells(r, [COLOR=Black]"[COLOR=Red]g[/COLOR]"[/COLOR]).Value & aranan
a = InStr(Trim(adres), aranan)
For j = 1 To Len(adres)
i = InStr(j, adres, aranan, vbTextCompare)
If i > 0 Then
yer = WorksheetFunction.Trim(Mid(Cells(r, "[COLOR=Red]g[/COLOR]").Value, j, i - j))
 
For t = 1 To Len(yer)
If IsNumeric(Mid(yer, 1, t)) = False Then
Cells(sat, "[COLOR=Red]N[/COLOR]").Value = WorksheetFunction.Trim(Mid(yer, t, Len(yer)))
Cells(sat, "[COLOR=Red]M[/COLOR]").Value = WorksheetFunction.Trim(Mid(yer, 1, t - 1))
Exit For
End If
Next
If Cells(sat, "[COLOR=Red]M[/COLOR]").Value = "" Then
Cells(sat, "[COLOR=Red]O[/COLOR]").Value = 1
End If
sat = sat + 1
j = i
End If
Next
Next
Set j = CreateObject("Scripting.Dictionary")
For Each X In Range("[COLOR=Red]n[/COLOR]2:[COLOR=Red]n[/COLOR]" & Cells(Rows.Count, "[COLOR=Red]n[/COLOR]").End(3).Row)
aranan1 = Replace(Replace(LCase(X.Value), "İ", "i"), "I", "ı")
If aranan1 <> "" Then
If Not j.exists(aranan1) Then
j.Add aranan1, Nothing
s = s + 1
Cells(s + 1, "[COLOR=Red]j[/COLOR]").Value = X.Value
Cells(s + 1, "[COLOR=Red]l[/COLOR]").Value = WorksheetFunction.SumIf(Range("[COLOR=Red]n:n[/COLOR]"), Cells(s + 1, "[COLOR=Red]j[/COLOR]").Value, Range("[COLOR=Red]m:m[/COLOR]"))
If Cells(s + 1, "[COLOR=Red]l[/COLOR]").Value = 0 Then
Cells(s + 1, "[COLOR=Red]l[/COLOR]").Value = ""
End If
Cells(s + 1, "[COLOR=Red]k[/COLOR]").Value = WorksheetFunction.SumIf(Range("[COLOR=Red]n:n[/COLOR]"), Cells(s + 1, "[COLOR=Red]j[/COLOR]").Value, Range("[COLOR=Red]o:o[/COLOR]"))
If Cells(s + 1, "[COLOR=Red]K[/COLOR]").Value = 0 Then
Cells(s + 1, "[COLOR=Red]K[/COLOR]").Value = ""
End If

End If
End If
Next X
Columns("[COLOR=Red]M:O[/COLOR]").ClearContents
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub
 
Kod

Kod:
Option Explicit
Sub aktar()
Application.ScreenUpdating = False
Dim aranan, aranan1, adres, sat, i, a, j, s, X, r, yer, t
sat = 2
Columns("J:O").ClearContents
aranan = "+"
For r = 2 To Cells(Rows.Count, "g").End(3).Row
adres = Cells(r, 7).Value & aranan
a = InStr(Trim(adres), aranan)
For j = 1 To Len(adres)
i = InStr(j, adres, aranan, vbTextCompare)
If i > 0 Then
yer = WorksheetFunction.Trim(Mid(Cells(r, "g").Value, j, i - j))
 
For t = 1 To Len(yer)
If IsNumeric(Mid(yer, 1, t)) = False Then
Cells(sat, "N").Value = WorksheetFunction.Trim(Mid(yer, t, Len(yer)))
Cells(sat, "M").Value = WorksheetFunction.Trim(Mid(yer, 1, t - 1))
Exit For
End If
Next
If Cells(sat, "M").Value = "" Then
Cells(sat, "o").Value = 1
End If
sat = sat + 1
j = i
End If
Next
Next
Set j = CreateObject("Scripting.Dictionary")
For Each X In Range("n2:n" & Cells(Rows.Count, "n").End(3).Row)
aranan1 = Replace(Replace(LCase(X.Value), "İ", "i"), "I", "ı")
If aranan1 <> "" Then
If Not j.exists(aranan1) Then
j.Add aranan1, Nothing
s = s + 1
Cells(s + 1, "j").Value = X.Value
Cells(s + 1, "l").Value = WorksheetFunction.SumIf(Range("n:n"), Cells(s + 1, "j").Value, Range("m:m"))
If Cells(s + 1, "l").Value = 0 Then
Cells(s + 1, "l").Value = ""
End If
Cells(s + 1, "k").Value = WorksheetFunction.SumIf(Range("n:n"), Cells(s + 1, "j").Value, Range("o:o"))
If Cells(s + 1, "K").Value = 0 Then
Cells(s + 1, "K").Value = ""
End If

End If
End If
Next X
Columns("M:O").ClearContents
Application.ScreenUpdating = True
MsgBox "işlem tamam"
End Sub

Harika oldu Halit Bey. Emeğinize sağlık.
Ben kodları inceleyeceğim inşallah. Ancak vaktiniz olduğunda şu soruma bir cevap bulabilir miyim. Verilerin hesaplandığı "K" ve "L" sütunlarını taşımak istersem, yani başka bir sütünda hesaplasın istersem formülün neresindeki "K" ve "L" yi değiştireyim?
 
Harika oldu Halit Bey. Emeğinize sağlık.
Ben kodları inceleyeceğim inşallah. Ancak vaktiniz olduğunda şu soruma bir cevap bulabilir miyim. Verilerin hesaplandığı "K" ve "L" sütunlarını taşımak istersem, yani başka bir sütünda hesaplasın istersem formülün neresindeki "K" ve "L" yi değiştireyim?

Yukarıdaki mesajdaki kodda değişecek yerleri kırmızı ile belirledim.
 
Geri
Üst