tahsinanarat
Altın Üye
- Katılım
- 14 Mart 2005
- Mesajlar
- 2,181
- Excel Vers. ve Dili
- Ofis 2019 Türkçe
Sn. Halit Bey, 31 olan PANAX toplamını 17 olarak veriyor. Bilgilerinize.
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sn. Halit Bey, 31 olan PANAX toplamını 17 olarak veriyor. Bilgilerinize.
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
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.
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.
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
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?
Merhaba,
#30 nolu mesajımdaki fonksiyonu "i-İ" harflerini algılayacak şekilde düzenledim. Tekrar denermisiniz.
Söylediklerinizi anladığım kadarıyla yapmaya çalıştım 22 nolu mesajdaki kodu güncelledim.
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...
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?