Her Hücreye Bir Harf

[Yüksel Varlı]

Merhaba arkadaşlar,
Userform üzerindeki Textbox a girilen örneğin "ALİ" kelimesini, A1 e "A"; B1 e "L" ; C1 e "İ" şeklinde kaydedebilir miyiz? (kelime daha uzun da olabilir)
Selamlar

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

 

[ozgretmen]

Dosya ekte...Alternatif olsun...

 

[Yüksel Varlı]

Değerli Korhan Ayhan & ozgretmen,
ilginiz için teşekkür ederim. Ben uğraşırken şöyle komik bir çözüm bulmuştum. Ama döngü ile yapmak gerçekten çok tasarruflu oldu. Her açıdan...
TEŞEKKÜRLER

[G17] = Left((UserForm1.txtkurum.Value), 1)
[H17] = Mid((UserForm1.txtkurum.Value), 2, 1)
[I17] = Mid((UserForm1.txtkurum.Value), 3, 1)
[J17] = Mid((UserForm1.txtkurum.Value), 4, 1)
[K17] = Mid((UserForm1.txtkurum.Value), 5, 1)
[L17] = Mid((UserForm1.txtkurum.Value), 6, 1)
[M17] = Mid((UserForm1.txtkurum.Value), 7, 1)
[N17] = Mid((UserForm1.txtkurum.Value), 8, 1)
[O17] = Mid((UserForm1.txtkurum.Value), 9, 1)
[P17] = Mid((UserForm1.txtkurum.Value), 10, 1)
[Q17] = Mid((UserForm1.txtkurum.Value), 11, 1)
[R17] = Mid((UserForm1.txtkurum.Value), 12, 1)
[S17] = Mid((UserForm1.txtkurum.Value), 13, 1)
[T17] = Mid((UserForm1.txtkurum.Value), 14, 1)
[U17] = Mid((UserForm1.txtkurum.Value), 15, 1)
[V17] = Mid((UserForm1.txtkurum.Value), 16, 1)
[W17] = Mid((UserForm1.txtkurum.Value), 17, 1)
[X17] = Mid((UserForm1.txtkurum.Value), 18, 1)
[Y17] = Mid((UserForm1.txtkurum.Value), 19, 1)
[Z17] = Mid((UserForm1.txtkurum.Value), 20, 1)
[AA17] = Mid((UserForm1.txtkurum.Value), 21, 1)
[AB17] = Mid((UserForm1.txtkurum.Value), 22, 1)
[AC17] = Mid((UserForm1.txtkurum.Value), 23, 1)
[AD17] = Mid((UserForm1.txtkurum.Value), 24, 1)
[AE17] = Mid((UserForm1.txtkurum.Value), 25, 1)
[AF17] = Mid((UserForm1.txtkurum.Value), 26, 1)
[AG17] = Mid((UserForm1.txtkurum.Value), 27, 1)
[AH17] = Mid((UserForm1.txtkurum.Value), 28, 1)

 

[Yüksel Varlı]

Merhaba,
20ye yakın txt kutusu var. aşağıdaki gibi bir döngü oluşturmaya çalıştım ama başaramadım.

Dim X As Integer
Dim süt As Integer
'If txtkurum <> Empty Then
For X = 1 To Len(txtkurum)
If X >= 257 Then GoTo Son
Cells(17, X + 6) = Mid(txtkurum, X, 1)
Cells(19, X + 6) = Mid(txtbirim, X, 1)
Cells(21, X + 6) = Mid(txtadres, X, 1)
Cells(25, X + 7) = Mid(txtil, X, 1)
Cells(25, X + 15) = Mid(txtilkodu, X, 1)
Cells(25, X + 23) = Mid(txtilçe, X, 1)
''####
Next
End If
Exit Sub
Son:
MsgBox "Tüm sütunlar dolmuştur !", vbCritical, "Dikkat !"

 

[ozgretmen]

Kodu aşağıdaki gibi değiştirin:

Private Sub CommandButton10_Click()
Sheets("giriş formu").Select
Range("G17:AG17, G19:AG19, G21:AG21, H25:S25, U25:V25, X25:AG25").Select
Selection.ClearContents

    Dim X As Integer
    Dim süt As Integer
    'If txtkurum <> Empty Then
    For X = 1 To Len(txtkurum)
    If X >= 257 Then
    MsgBox "Tüm sütunlar dolmuştur !", vbCritical, "Dikkat !"
    Exit Sub
    Else
    Cells(17, X + 6) = Mid(txtkurum, X, 1)
        Cells(19, X + 6) = Mid(txtbirim, X, 1)
            Cells(21, X + 6) = Mid(txtadres, X, 1)
                Cells(25, X + 7) = Mid(txtil, X, 1)
                    Cells(25, X + 15) = Mid(txtilkodu, X, 1)
                        Cells(25, X + 23) = Mid(txtilçe, X, 1)

    End If
    Next X
End Sub

 

[Yüksel Varlı]

Hocam Teşekkürler,
Ama döngüye
For X = 1 To Len(txtkurum)
satırındaki len(txt.........) bölümünü de eklemek lazım galiba. Ben biraz uzunca bir yolla da olsa şimdilik hallettim sorunu. Kaç tane text kutusu varsa o kadar kod yazdım. Şık olmadı ama sorunu çözdü.
Selamlar