- Katılım
- 28 Mart 2019
- Mesajlar
- 33
- Excel Vers. ve Dili
- Excel 2007
Selamlar. Kullandığım makro bir ve iki basamaklı sayılara ilişkin hesaplama yaparken doğru sonuç veriyor. Fakat üç ve daha fazla basamaklı sayı kullanınca şekilsel bozukluklar ortaya çıkıyor. İki ayrı ekran görüntüsü paylaştım. Örnek1' de tek basamaklı sayılar kullanılmış, sütun E'de "2,5" şeklinde sonuç alınmış. Kategori "genel" gözüküyor. Şimdi Örnek2' ye bakalım. burada da 1000,2001 gibi iki adet üç basamaklı sayı kullanılmış. E' deki sonuç 1000,2001 olması gerekirken 10.002.001 gibi ucube bir şey ortaya çıkıyor ve kategorisi "sayı" olarak gözüküyor. Buradaki sorunu gidermek için, bu şekil bir hatalı sonuç çıktısı vermemesi için ne yapmak gerek ? Kullandığım makroyu da aşağıda görebilirsiniz. Yardımcı olabilirseniz çok sevinirim. Herkese iyi haftasonları diliyorum..
NOT: Resim ekleyemiyorum. Linklere ekledim https://hizliresim.com/5sniqso https://hizliresim.com/77hzmro
NOT: Resim ekleyemiyorum. Linklere ekledim https://hizliresim.com/5sniqso https://hizliresim.com/77hzmro
Kod:
Sub ortakListeKarsilastir()
'31032023 hesaplama
Application.ScreenUpdating = False
Dim ortakDegerler, elem, listeDic As Object, aList, bList, i, ii, al, ver, dic As Object, itms, kys
Set listeDic = CreateObject("Scripting.Dictionary")
Set dic = CreateObject("Scripting.Dictionary")
ortakDegerler = Split(Range("D2").Value, ",")
aList = Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).Value
bList = Range("B2:C" & Cells(Rows.Count, 2).End(3).Row).Value
For i = 1 To UBound(aList)
al = ortakDegerAl(aList(i, 1), ortakDegerler, dic)
aList(i, 2) = ""
If al = "" Then
al = Trim(aList(i, 1))
ver = "D[" & i + 1 & " > " & aList(i, 1) & "]"
If Not listeDic.exists(al) Then
listeDic(al) = ver
Else
listeDic(al) = listeDic(al) & " ** " & ver
End If
Else
aList(i, 2) = al
End If
Next i
For i = 1 To UBound(bList)
bList(i, 2) = ""
al = ortakDegerAl(bList(i, 1), ortakDegerler, dic)
If al = "" Then
al = Trim(bList(i, 1))
ver = "C[" & i + 1 & " > " & bList(i, 1) & "]"
If Not listeDic.exists(al) Then
listeDic(al) = ver
Else
listeDic(al) = listeDic(al) & " ** " & ver
End If
Else
bList(i, 2) = al
End If
Next i
For i = 1 To UBound(aList)
For ii = 1 To UBound(bList)
If aList(i, 2) = bList(ii, 2) Then
al = birlestir(aList(i, 1) & "," & bList(ii, 1), dic)
ver = IIf(aList(i, 2) <> "", "A[", "B[") & i + 1 & " - " & ii + 1 & " > " & aList(i, 1) & " - " & bList(ii, 1) & "]"
If Not listeDic.exists(al) Then
listeDic(al) = ver
Else
listeDic(al) = listeDic(al) & " ** " & ver
End If
End If
Next ii
Next i
Range("E1:F" & Cells(Rows.Count, "E").End(3).Row).ClearContents
kys = listeDic.keys
itms = listeDic.items
For i = 0 To UBound(kys)
Cells(i + 1, "E").Value = kys(i)
Cells(i + 1, "F").Value = itms(i)
Next i
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("E1:F" & Cells(Rows.Count, "E").End(3).Row)
.Apply
End With
Application.ScreenUpdating = True
End Sub
Function birlestir(liste, dic)
Dim elem, al, i, ii
With dic
.RemoveAll
For Each elem In Split(liste, ",")
.Item(Val(elem)) = Null
Next elem
al = .keys
If UBound(al) > 0 Then
For i = 0 To UBound(al) - 1
For ii = i + 1 To UBound(al)
If al(i) > al(ii) Then
elem = al(ii)
al(ii) = al(i)
al(i) = elem
End If
Next ii
Next i
End If
End With
birlestir = Join(al, ",")
End Function
Function ortakDegerAl(liste, ortakDegerler, dic)
Dim elem, al
With dic
.RemoveAll
For Each elem In Split(liste, ",")
.Item(elem) = Null
Next elem
For Each elem In ortakDegerler
If .exists(elem) Then
al = al & " " & elem
End If
Next elem
End With
ortakDegerAl = Trim(al)
End Function
