DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub test()
Dim veri, i, ii, ky, a, kys, metin, bul
veri = Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(veri)
ky = veri(i, 2)
.Item(ky) = .Item(ky) & ", " & veri(i, 1)
Next i
kys = .keys
For i = 0 To UBound(kys)
ky = kys(i)
a = Mid(.Item(ky), 3)
If InStr(a, ",") Then
a = StrReverse(a)
bul = InStr(a, ",")
a = StrReverse(Left(a, bul - 1) & "ev " & Mid(a, bul + 1))
End If
kys(i) = kys(i) & " için " & a
Next i
metin = Join(kys, ", ")
End With
MsgBox metin
End Sub
emeğinize sağlık sayın veyselemre, gayet güzel çalışıyor.Kod:Sub test() Dim veri, i, ii, ky, a, kys, metin, bul veri = Range("A2:B" & Cells(Rows.Count, 1).End(3).Row).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(veri) ky = veri(i, 2) .Item(ky) = .Item(ky) & ", " & veri(i, 1) Next i kys = .keys For i = 0 To UBound(kys) ky = kys(i) a = Mid(.Item(ky), 3) If InStr(a, ",") Then a = StrReverse(a) bul = InStr(a, ",") a = StrReverse(Left(a, bul - 1) & "ev " & Mid(a, bul + 1)) End If kys(i) = kys(i) & " için " & a Next i metin = Join(kys, ", ") End With MsgBox metin End Sub
Çok sağolun Korhan BeyAlternatif;
Özet tablo ve yardımcı alan kullanarak çözüm ektedir.