Excel vba: excel textbok özellikleri

excel textbok özellikleri

‘TextBox’a en sondaki hücre değerinin yazdırılması

Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()

txtLastValue.Text = Cells( _
Cells(Rows.Count, 1).End(xlUp).Row, 1).Text
End Sub

‘Textbox taki satırlara ayrılmış verileri hücrelere yazdırır

Option Explicit

Private Sub cmdEintragen_Click()

Dim iRow As Integer
Dim sTxt As String
sTxt = txtText.Text
sTxt = WorksheetFunction.Substitute(sTxt, vbLf, "")
Do
iRow = iRow + 1
If InStr(sTxt, vbCr) Then
Cells(iRow, 1).Value = Left(sTxt, InStr(sTxt, vbCr) - 1)
sTxt = Right(sTxt, Len(sTxt) - InStr(sTxt, vbCr))
Else
Cells(iRow, 1).Value = sTxt
Exit Do
End If
Loop
Unload Me
End Sub

Private Sub UserForm_Initialize()
txtText.Text = _
"A.Aşkın KÜÇÜKKAYA" & vbCr & _
"Kabataş Ordu" & vbCr & _
"52520" & vbCr & _
"http://www.kod.gen.tr" & vbCr & _
"Excel Ötesi" & vbCr & _
"askinkk@kod.gen.tr"
cmdEintragen.SetFocus
End Sub

‘Textbox’a sadece rakam girebilirsiniz

Private Sub txtNumber_Change()

Dim sTxt As String
sTxt = txtNumber.Text
If sTxt = "" Then Exit Sub
If Right(sTxt, 1) Like "[0-9]" = False Then
txtNumber.Text = Left(sTxt, Len(sTxt) - 1)
End If
End Sub

‘Textboxsa 0 ile 9 arasında rakam girebilirsiniz.

Private Sub TextBox1_KeyPress _
(ByVal KeyAscii As MSForms.ReturnInteger)

If InStr(1, "0123456789", Chr(KeyAscii)) = 0 Then
KeyAscii = 0
End If
End Sub

'TextBox kutularına 1 den 5'e kadar sayı atar

Private Sub UserForm_Initialize()

Dim iCounter As Integer
For iCounter = 1 To 5
Controls("txt" & iCounter).Text = iCounter
Next iCounter
End Sub

'Textbox a yazılan yazı aynı anda hücreye yazılır

Private Sub txtEdit_Change()

Range("A1").Value = txtEdit.Text
End Sub

'A1 hücre değerinin textbox a alınması

Private Sub UserForm_Initialize()

txtEdit.Text = Range("A1").Value
End Sub

'TextBox a sadece tarih girebilirsiniz, Tarihi 31122005 şeklinde yazınca 31.12.2005 şeklinde biçimlendirir

Private Sub txtDate_Change()

Dim sDate As String
sDate = txtDate.Text
If sDate = "" Then Exit Sub
If Not Right(sDate, 1) Like "[0-9]" Then
sDate = Left(sDate, Len(sDate) - 1)
txtDate.Text = sDate
End If
If Len(sDate) = 6 Then
sDate = Format(DateSerial( _
"20" & Right(sDate, 2), _
Mid(sDate, 3, 2), _
Left(sDate, 2) _
), "dd.mm.yy")
txtDate.Text = sDate
End If
End Sub

'textboxtaki istenilen kelimeleri seçer, Örneğin 01.02.2005 tarihindeki ayı seçtirmek istiyorsanız bu kodu çalıştırmanız yeterli

Private Sub cmdFirst_Click()

With txtFirst
.SetFocus
.SelStart = 3 '3. karekterden başlar
.SelLength = 2 '2 karekter seç
End With
End Sub

'user form açılırken textbox'a istediğiniz formatta tarih yazdırır.

Private Sub UserForm_Initialize()

txtFirst.Text = Format( _
DateSerial(Year(Date), Month(Date), 12), "dd.mm.yyyy")
End Sub

'Textbox taki veriyi userform açılırken seçer

Private Sub UserForm_Initialize()

With TextBox1
.Value = "www.kod.gen.tr"
.SelStart = 0
.SelLength = .TextLength
End With

'textboxsa, günü ve ayı yazın yılı otomatik tamamlasın 'tarih girişlerinde aralara nokta girmenize gerek yoktur.

Private Sub txtDatum_Change()
'textboxsa, günü ve ayı yazın yılı otomatik tamamlasın
'tarih girişlerinde aralara nokta girmenize gerek yoktur.
Dim dat As Date
Dim iRow As Integer
Dim sTxt As String
sTxt = txtDatum.Text
If sTxt = "" Then Exit Sub
If Right(sTxt, 1) Like "[0-9]" = False Then
Beep
sTxt = Left(sTxt, Len(sTxt) - 1)
txtDatum.Text = sTxt
End If
If Len(sTxt) = 4 Then
On Error Resume Next
dat = DateSerial(Year(Date), Right(sTxt, 2), Left(sTxt, 2))
If Err > 0 Then
MsgBox "Hatalı Tarih Girişi"
Err = 0
txtDatum.Text = ""
Exit Sub
End If
iRow = WorksheetFunction.CountA(Columns(1)) + 1
Cells(iRow, 1) = dat
txtDatum.Text = ""
End If
End Sub

'Textbox taki sayıyı hücreye istediğiniz formatta yazdırır

Private Sub cmdEintragen_Click()

Dim dValue As Double

If optWaehrung.Value = True Then
'ondalıklı sayı olarak ve sonuna para simgesini
'yazdırır (13,52 YTL)
Range("A1").NumberFormat = "#,##0.00 $"
ElseIf optKolonne.Value = True Then
'ondalıklı sayı olarak yazdırır (13,52)
Range("A1").NumberFormat = "#,##0.00"
ElseIf optSingle.Value = True Then
'Ondalıklı kısmı atarak yazar (13)
Range("A1").NumberFormat = "0"
Else
'Rakamın sonuna & işareti koyar (13,52%)
Range("A1").NumberFormat = "0.00%"
End If
dValue = CDbl(txtWert.Text)
If optProzent.Value = True Then dValue = dValue / 100
Range("A1") = dValue
End Sub

'Textbox şifre girme

Private Sub cmdOK_Click()

'Eğer textbox'a girilen şifrelerin karekter olarak
'*** şeklinde olmasını istiyor iseniz PasswordChar değerine
' * karekterini giriniz.
If txtPasswort.Text = "kodgentr" Then
MsgBox "Tebrikler! Şifre Doğrulandı"
Unload Me
Else
MsgBox "Üzgünüm! Yazdığınız Şifre Hatalı"
txtPasswort.Text = ""
txtPasswort.SetFocus
End If

End Sub

hücredeki değeri textbox'a ondalıklı değere yuvarlayarak atar (35,435689 = 35,44'

Private Sub cmdAusTabelle_Click()
txtRunden.Value = WorksheetFunction.Round( _
Range("A1").Value, 2)
End Sub

'1. textboxtaki değerie 2. textbox a ondalık formatta transfer eder (12,34567 = 12,35)

Private Sub cmdAusTextBox_Click()

txtRunden.Value = WorksheetFunction.Round( _
CDbl(txtBasis.Value), 2)
End Sub

'textbox a yazılan kelimeler arasında boşluk vermeye izin vermez

Private Sub txtPruefung_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

If Chr(KeyAscii) Like "[0-9 a-z A-Z]" = False Or _
KeyAscii = 32 Then
Beep
MsgBox "Lütfen kelimeler arasında boşluk vermeyin"
KeyAscii = 0
End If
End Sub

'textbox a girilen değerlerin önündeki 'boşlukları yok eder

Private Sub cmdMargin_Click()

With txtMargin
.SelectionMargin = Not .SelectionMargin
.SetFocus
End With


End Sub

'textbox kutusundaki harfleri scrollbar ile heceler 'tek tek seçim yapar

Private Sub scbSelect_Change()

scbSelect.SetFocus
txtSelect.SelStart = scbSelect.Value
txtSelect.SelLength = 1
txtSelect.SetFocus
End Sub

'userformun açılışında ilk karekteri seçer

Private Sub UserForm_Initialize()

With txtSelect
.SetFocus
.SelStart = 0
.SelLength = 1
End With
scbSelect.Max = Len(txtSelect.Text) - 1
End Sub

'eğer textbox taki karekter sayısı 16 dan küçakse 'userformun kapatılmasını engeller

Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

If Len(TextBox1.Text) < 16 Then Cancel = True
End Sub

'Textbox a 16 karetkter yani tarih ve saat 'girebilirsiniz. Başka türlü userform kapanmaz

Private Sub TextBox1_Change()

If Len(TextBox1.Text) = 16 Then
If IsDate(TextBox1.Text) = False Then
MsgBox "İstenilen Sayıda Karekter Girdiniz"
Else
‘Mesaj kutusunda soldan 10 sağdan 5 karakteri gösterir
MsgBox "Tarih: " & Left(TextBox1.Text, 10) & vbLf & "Saat: " & _
Right(TextBox1.Text, 5)
End If
End If
End Sub

'Eğer girilen değerler rakam değilse textbox u sıfıla

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

If Chr(KeyAscii) Like "[0-9.: ]" = False Then
KeyAscii = 0
End If
End Sub

'textbox'a belli bir aralıktaki değerleri alır 'textbox u Listbox gibi kullanın

Private Sub UserForm_Initialize()

Dim lngRow As Long
Dim strTxt As String
lngRow = 1
Do Until IsEmpty(Cells(lngRow, 1))
strTxt = strTxt & Cells(lngRow, 1) & vbLf
lngRow = lngRow + 1
Loop
txt.Text = Left(strTxt, Len(strTxt) - 1)
End Sub

'ilk ve 2. textboxa girilen tarihler arasında 'Excel hücrelerine seri tarih yazar

Private Sub cmdOK_Click()


Dim datStart As Date, datEnde As Date
Dim iRow As Integer
datStart = DateValue(txtStart.Text)
datEnde = DateValue(txtEnde.Text)
For iRow = 1 To datEnde - datStart + 1
Cells(iRow, 1) = datStart + iRow - 1
Next iRow
Unload Me
End Sub

'textbox a yanlış tarih girmenize izin vermez 'örneğin 12.13.2005 yazarsanız uyarır 'çünkü bir yılda 12 ay vardır.

Private Sub UserForm_Initialize()

Dim intCounter As Integer
For intCounter = 1 To 4
Set txtBoxes(intCounter).TxtGroup = Controls("TextBox" & intCounter)
Next intCounter
End Sub

'1. ve 2. textboxtaki tarihler arasındaki hücrelerin 'önündeki hücreye x işareti koyar

Private Sub cmdOK_Click()

Dim rngStart As Range, rngEnd As Range
Set rngStart = Columns(1).Find( _
what:=DateValue(txtStart.Text), LookIn:=xlFormulas)
Set rngEnd = Columns(1).Find( _
what:=DateValue(txtEnd.Text), LookIn:=xlFormulas)
Columns("B").Clear
Range(rngStart, rngEnd).Offset(0, 1).Value = "X"
End Sub

'Aktif Hücreye Inputbox u çağırır ve textboxsa değeri yazar 'Böylece aynı metni yazacağınız Textboxları doldurmanız hızlanır

Private Sub cmdOK_Click()

Dim txt As String
txt = InputBox("Textbox'a Aktaracağınız Metni yazın:", , "www.kod.gen.tr")
If txt = "" Then End
gtxtBox.Text = txt
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Set gtxtBox = Controls("TextBox1")
End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Set gtxtBox = Controls("TextBox2")
End Sub

Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Set gtxtBox = Controls("TextBox3")
End Sub

Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Set gtxtBox = Controls("TextBox4")
End Sub

'Textboxa girdiğiniz değerin hücre aralığında daha önce yazılıp 'yazılmadığını kontrol eder. Eğer daha Önce yazılmışsa 'aynı veriyi tekrar yazmaz

Private Sub cmdOK_Click()

Dim var As Variant
Dim intRow As Integer
var = Application.Match(CDbl(txtValue.Text), Columns(1), 0)
If Not IsError(var) Then
MsgBox "Bu Sayı Daha Önce Girilmiş!"
Else
intRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(intRow, 1) = txtValue.Text
End If
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

'Textboxx tan seçilen Resimlere Link verir

Private Sub cmdOK_Click()

Dim iCounter As Integer
Dim sTag As String
Rows(1).Clear
For iCounter = 1 To 3
sTag = Controls("CommandButton" & iCounter).Tag
Cells(1, iCounter).Value = Controls("TextBox" & iCounter).Text
If sTag <> "False" And sTag <> "" Then
ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(1, iCounter), _
Address:=sTag
End If
Next iCounter
Unload Me
End Sub

Private Sub CommandButton1_Click()
CommandButton1.Tag = SelectPicture
End Sub

Private Sub CommandButton2_Click()
CommandButton2.Tag = SelectPicture
End Sub

Private Sub CommandButton3_Click()
CommandButton3.Tag = SelectPicture
End Sub

Private Function SelectPicture()
Dim var As Variant
var = Application.GetOpenFilename("İzin Verilen Formatlar (*.gif), *.gif")
If var = False Then
SelectPicture = "False"
Else
SelectPicture = var
End If
End Function

'Excel Tablosundaki parça nosunu textbox a girince 'o numaraya denk gelen parçalar listbox ta listelenir 'ara bul

Private Sub txtValue_Change()

Dim arr() As Variant
Dim iRow As Integer, iCol As Integer, iCounter As Integer
If txtValue.TextLength = 4 Then
iRow = 2
Do Until IsEmpty(Cells(iRow, 1))
If Cells(iRow, 1) = txtValue.Text Then
iCounter = iCounter + 1
ReDim Preserve arr(1 To 4, 1 To iCounter)
For iCol = 1 To 4
arr(iCol, iCounter) = Cells(iRow, iCol).Value
Next iCol
End If
iRow = iRow + 1
Loop
lstValues.Column = arr
End If
End Sub

'kapalı dosyadan textbox a veri alır

Private Sub cmdOK_Click()

Dim sPath As String, sFile As String, sWks As String
Dim sRange As String
sPath = "c:\test"
sFile = "test.xls"
sWks = "Sayfa1"
sRange = "askin"
If Dir(sPath & "\" & sFile) = "" Then
Beep
MsgBox "Tarih " & sFile & " "
Exit Sub
End If
On Error Resume Next
Range("IV1").Formula = "='" & sPath & _
"\[" & sFile & "]" & sWks & "'!" & sRange
txtImport.Text = Range("IV1").Value
Range("IV1").ClearContents
End Sub

'Textbox a girilen değer sürekli hücredeki değerin üzerine toplama yapar

Private Sub cmdOK_Click()


If TextBox1.Text <> "" Then
Range("A1").Value = Range("A1").Value + CDbl(TextBox1.Text)
End If
If TextBox2.Text <> "" Then
Range("B3").Value = Range("B3").Value + CDbl(TextBox2.Text)
End If
If TextBox3.Text <> "" Then
Range("C6").Value = Range("C6").Value + CDbl(TextBox3.Text)
End If
End Sub

'Eğer Textboxsa sizin istediğiniz değer girilmezse textboxtan çıkılamaz

Private Sub TextBox1_Exit _
(ByVal Cancel As MSForms.ReturnBoolean)

If TextBox1.Value <> "Aşkın" Then
MsgBox "Yanlış Veri"
TextBox1.SetFocus
Cancel = True
End If
End Sub

‘textbox taki veri 5 karekterden fazla olursa kabul edilmez

Private Sub TextBox1_Exit _
(ByVal Cancel As MSForms.ReturnBoolean)

If Len(TextBox1.Text) > 5 Then
MsgBox "Fazla Karakter Girdiniz"
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
End If
End Sub

'textboxtaki 3 adet textbox taki değerleri A1-B1-C1 hücrelerine sırayla yazdırır

Private Sub CommandButton1_Click()

Dim i As Integer
For i = 1 To 3
Cells(1, i) = Controls("Textbox" & i)
Next i
End Sub

'1. sütunda aynı değerde 2 kayıt yapalamaz (mükerrer)

Private Sub CommandButton1_Click()

Dim temp, temp1

temp = TextBox1.Value
temp1 = IIf(Application.CountIf(Columns(1), temp) > 0, 1, 0)

If temp1 > 0 And TextBox1.Value <> "" Then
MsgBox "Aynı Kayıttan Bulundu"
Else
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = temp
End If
End Sub

Soru

textboxtaki değer mesala 56,50 ise bunu 57veya 56,49 ise bunu 56 olarak nasıl göstere bilirim.Bunu sağlayabilecek bir Function arıyom

Cevap

TextBox1.Value = Round(TextBox1.Value, 0)
TextBox1.Value = CLng(TextBox1.Value)

Private Sub TextBox1_Exit _
(ByVal Cancel As MSForms.ReturnBoolean)
'Eğer Textboxsa sizin istediğiniz değer girilmezse textboxtan çıkılamaz
If TextBox1.Value <> "Aşkın" Then
MsgBox "Yanlış Veri"
TextBox1.SetFocus
Cancel = True
End If
End Sub

Private Sub TextBox1_Exit _
(ByVal Cancel As MSForms.ReturnBoolean)
‘textbox taki veri 5 karekterden fazla olursa kabul edilmez
If Len(TextBox1.Text) > 5 Then
MsgBox "Fazla Karakter Girdiniz"
TextBox1.SelStart = 0
TextBox1.SelLength = Len(TextBox1.Text)
End If
End Sub

Kaynak: Excel vba Örnek Dosyalar Cd'si

TextBox Özellikleri

ÖRNEK DOSYALAR CD'Sİ

Sosyal Bağlantılar

Kategoriler

Popüler Yayınlar

Rastgele