DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Merhaba,Excel'e uyarlarım.
Merhaba,Bu kutucuklar ayrı ayrı tabloların hücreleri mi?
İlginiz için teşekkür ederim. Zaten dediğiniz gibi yapıyorum. Sizin paylaştığınız dosya ile bizim dosya arasında fark göremedim.sol tuşu veya tab tuşu ile geçip, harf veya karakteri yazabilirsiniz.
Sub Doldur()
Dim OriginalRange As Range, var As Integer
Dim l As Integer, m As Integer, n As Integer, O As Integer
Dim p As Variant, kelime As Variant
If Selection.Information(wdWithInTable) = True Then
Set OriginalRange = Selection.Range
kelime = UCase(Trim(InputBox(vbLf & "Kelimeyi giriniz", "VERİ GİRİŞİ")))
If kelime = "" Then
Exit Sub
End If
m = Len(kelime)
n = Selection.Tables(1).Columns.Count
O = Selection.Information(wdStartOfRangeColumnNumber)
If n + 1 >= O + 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 - (O - 1) >= 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
If n - (O - 1) >= m Then
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
Else
MsgBox "Bulunduğunuz hücreden itibaren " & n - (O - 1) & " adet kutu var." & vbLf _
& "Girmek istediğiniz " & kelime & " değeri " & m & " karakter uzunluğundadır!"
End If
End If
ElseIf var = 0 And n - (O - 1) >= 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 - (O - 1) & " 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
Bu şekilde daha hızlı oldu... Değerli yardımınız için teşekkür ederim.Ekteki örnekte, Makro içeren word dosyası var.
Necati Hocam merhaba,Merhaba, alternatif olsun
Necati Hocam,Makroyu kısayol tuşuna atarsanız pratik olur.