array ile sayıları sayı ve özel karakterlere dönüştürmek

[necati]

Merhabalar,
A sütununda dört haneli sayılarım var. Bunları Arabi rakamların html koduna dönüştürüp B sütununa yazdıracağım. Yada kısaca:
Array1 deki 0-9 arası rakamları Array2 deki bazı özel karakterlere dönüştürmek istiyorum. Ancak özel karakterler ( gibi) ve değişen değerin tekrar değişmememesi için nasıl bir makro yapılabilir. Mesela içindeki 0'ı, 1'i, 6'yı, 4'ü tekrar değiştirmemesi gerekiyor.

Array1("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
Array2("", "", "", "", "", "", "", "", "", "")

mesela 1234 sayısı " şeklinde yazılacak
Not: Array2'deki büyük Q harflerini mecburiyetten koydum. Orjinal html kodunda "Q" harflari olmayacak. Bunu koymasam burada bu kodları gösteremiyordum.

 

[Ömer]

Merhaba,

Function cevir(deger As String) As String
 
    Dim eski
    Dim yeni
    Dim i As Byte
 
    eski = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
    yeni = Array("", "", "", "", "", _
                "", "", "", "", "")
    For i = 0 To 9
        deger = Replace(deger, eski(i), yeni(i))
    Next i
 
    cevir = UCase(deger)
 
End Function

Gibi kullanıcı tanımlı fonksiyon kullanabilirsiniz.

.

 

[necati]

Maalesef bu fonksiyon sorumda da belirttiğim gibi değişen değerin tekrar değişmesine yol açarak uzun bir değer ortaya çıkartıyor.

 

[Orion1]

Aşağıdaki fonksiyonu deneyiniz
Not ben ilk 3 için yazdım.diğerlerini siz yazınız.

Function cevir(deg As Range) As String
'coder : evrengizlen@hotmail.com
'date:10.07.2011
Dim col As Collection, i As Long
Set col = New Collection
col.Add "", "0"
col.Add "", "1"
col.Add "", "2"
For i = 1 To Len(deg)
    deg2 = deg2 & col(Mid(deg, i, 1))
Next
cevir = deg2
End Function

 

[necati]

Bu kod hep aynı değeri döndürüyor.

 

[Orion1]

4 nolu mesajda güncelledim.tekrar deneyiniz.

 

[necati]

Teşekkürler, şimdi oldu.

 

[Korhan Ayhan]

Merhaba,

Evren bey size çözümü sunmuş. Bende alternatif olarak Array yöntemi ile çözümü sunuyorum. İncelermisiniz.

Hücrede kullanım şekli;

[B][COLOR=blue]=HTML_KOD_ÇEVİR([COLOR=red]A1[/COLOR])[/COLOR][/B]

Option Explicit
 
Function HTML_KOD_ÇEVİR(Hücre As Range) As String
    Dim Eski As Variant, Yeni As Variant
    Dim X As Integer, Y As Byte
    
    Application.Volatile True
    
    Eski = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
    Yeni = Array("", "", "", "", "", "", "", "", "", "")
    
    For X = 1 To Len(Hücre.Text)
        For Y = 0 To 9
            If Mid(Hücre.Text, X, 1) = Eski(Y) Then
                HTML_KOD_ÇEVİR = HTML_KOD_ÇEVİR & Yeni(Y)
            End If
        Next
    Next
End Function