Word'de Her Kutucuğa bir harf

[necati]

Tek satır veya çoklu satır ihtimali de eklendi.

Sub Doldur2()
Dim OriginalRange As Range, var As Integer, sor As Integer
Dim l As Integer, m As Integer, n As Integer, O As Integer
Dim p As Integer, kelime As Variant

If Selection.Information(wdWithInTable) = True Then
    Set OriginalRange = Selection.Range
    sor = MsgBox(" Çoklu Satır Girişi mi Yapılacak?", vbYesNo + vbInformation, " Uyarı")

    kelime = UCase(Trim(InputBox(vbLf & "Kelimeyi giriniz", "VERİ GİRİŞİ")))
        If kelime = "" Then
            Exit Sub
        End If
    
    m = Len(kelime)
    O = Selection.Cells(1).ColumnIndex
    
    If sor = vbYes Then
        n = ((Selection.Tables(1).Columns.Count * _
        Selection.Tables(1).Rows.Count) - _
        ((Selection.Cells(1).RowIndex - 1) * _
        Selection.Tables(1).Columns.Count)) - O + 1
    Else
        n = (Selection.Tables(1).Columns.Count - Selection.Information(wdStartOfRangeColumnNumber)) + 1
        If n < m Then
            MsgBox "Bulunduğunuz hücreden itibaren " & n & " adet kutu var." & vbLf _
            & "Girmek istediğiniz " & kelime & " değeri " & m & " karakter uzunluğundadır!"
            Exit Sub
        End If
    End If
    
    If n >= m Then
        For l = 1 To n
            If Len(Trim(Selection.Cells(1).Range.Text)) > 2 Then
                var = var + 1
                If l >= m Then Exit For
                Selection.MoveRight Unit:=wdCell
            Else
                If l >= m Then Exit For
                Selection.MoveRight Unit:=wdCell
            End If
        Next l
        OriginalRange.Select
    
        If var > 0 And n >= m Then
            p = MsgBox("Kutularda değer var! Silinsin mi?", vbYesNo + vbInformation, " Uyarı")
            
            If p = vbNo Then
                MsgBox "işlemi iptal ettiniz.!"
                Exit Sub
            Else
                For l = 1 To m
                    Selection.Cells(1).Range.Text = ""
                    If l = m Then Exit For
                    Selection.MoveRight Unit:=wdCell
                Next l
        
                OriginalRange.Select
                For l = 1 To m
                    Selection.Cells(1).Range.Text = Mid(kelime, l, 1)
                    If l = m Then Exit For
                    Selection.MoveRight Unit:=wdCell
                Next l
            End If
        
        ElseIf var = 0 And n >= m Then
            For l = 1 To m
                Selection.Cells(1).Range.Text = Mid(kelime, l, 1)
                If l = m Then Exit Sub
                Selection.MoveRight Unit:=wdCell
            Next l
        End If
    Else
        MsgBox "Bulunduğunuz hücreden itibaren " & n & " adet kutu var." & vbLf _
        & "Girmek istediğiniz " & kelime & " değeri " & m & " karakter uzunluğundadır!"
    End If
Else
    MsgBox "Tablo üzerinde değilsiniz, tablodan bir kutu seçiniz.", vbCritical
End If

End Sub

 

[Mukteda]

Makroya kısayol tuşu atamak:

Necati Bey, Tamamdır. Sorunu çözdüm. Kolaylıklar dilerim.

Alternatif olsun

Halit Bey, Tamamdır. Çok teşekkür ederim. Sağ olun...