Textlere Veri Çekilmesi

ahmedummu · 16 Temmuz 2017

Merhaba arkadaşlar.

Ekte gönderdiğim örnek dosyada, SABAH ve OGLEN adlı iki excel sayfası ve bu sayfalarda da en fazla 25 kişi olan isimler bulunuyor. Şu anki durumu SABAH sayfasında 25 kişi, OGLEN sayfasında 23 kişi bulunuyor. Zamanla değişiyor her iki sayfada 20'şer kişi olduğu bile oluyor. Yapmak istediğim SABAH sayfasındaki isimleri aktarmak için Userform üzerinde 1'den 25' kadar 25 adet, OGLEN sayfasındaki isimleri aktarmak içinde 26'dan 50'ye kadar 25 adet textbox var. sayfalardaki isimleri bu textboxlara katarmak istiyorum. SABAH sayfasındaki isimleri sorunsuz aktarılıyır. Şu an 25 kişi var ama 25 kişiden az olsa da sorun çıkmıyor. OGLEN sayfasında 23 kişi olduğu için text26'dan text48'e kadar isimleri aktarıyor. Listeden 23 kişi olduğu için 2 Adet text boş kalıyor. text49 ve text50. Aşağıdaki kod ile SABAH sayfasında eksikte olsa sorun çıkmıyor. Aynı kodları OGLEN sayfası için yaptım ama bir türlü çalıştıramadım. Aşağıdaki kod 25 kişiden eksik olan sayfalarda eksik kişi sayısı kadar, isim aktarılmayan textlere ismi aktarılan isimlerden ikinci kez aktarma yapıyor.

Kod:

Dim sabahsayi, eksik As Byte
sabahsayi = WorksheetFunction.CountA(Range("a1:a30"))
eksik = 25 - sabahsayi
For i = 26 - eksik To i + eksik
Controls("textbox" & i).Value = Sheets("SABAH").Cells(i - eksik - 15, "a").Value & " (İKİNCİ NÖBET)"
Next i

Aşağıdaki de OGLEN için yaptığım kodlar

Kod:

Dim oglensayi, eksik As Byte
oglensayi = WorksheetFunction.CountA(Range("a1:a30"))
eksik = 25 - oglensayi
For i = 50 - eksik To i + eksik
Controls("textbox" & i).Value = Sheets("OGLEN").Cells(i - (40 + eksik), "a").Value & " (İKİNCİ NÖBET)"
Next i
End Sub

Yardımcı olursanız sevinirim.

halit3 · 16 Temmuz 2017

kodu şöyle birdene bakalım

Kod:

Sub sabahh()
Sheets("SABAH").Select
Dim varArr As Variant, varTemp As Variant
Dim random As Range
Dim X As Long, y As Long
'Dim say As Double
'say = Range("a65000").End(xlUp).Row
On Error Resume Next
'Set random = Sheets("NÖBET").Cells("a", say)
For z = 1 To 5
Set random = Sheets("SABAH").Range("A1:A30")
varArr = random.Value
Randomize
For X = 1 To UBound(varArr, 1)
    y = Int(Rnd() * UBound(varArr) + 1)
    varTemp = varArr(X, 1)
    varArr(X, 1) = varArr(y, 1)
    varArr(y, 1) = varTemp
Next X
random.Value = varArr
Next z
[a:a].SpecialCells(xlCellTypeBlanks).EntireRow.Delete

For i = 1 To 25
Controls("textbox" & i).Value = Sheets("SABAH").Cells(i, "a").Value
Next i

Dim sabahsayi, eksik As Byte
sabahsayi = WorksheetFunction.CountA(Range("a1:a30"))
eksik = 25 - sabahsayi
For r = 1 To eksik
Controls("textbox" & (r + 25) - eksik).Value = Sheets("SABAH").Cells(r, "a").Value & " (İKİNCİ NÖBET)"
Next r
'For i = [b65000].End(xlUp).Row To 5 Step -1
End Sub
Sub oglenn()
Sheets("OGLEN").Select
Dim varArr As Variant, varTemp As Variant
Dim random As Range
Dim X As Long, y As Long
For v = 1 To 5
Set random = Sheets("OGLEN").Range("a1:a30")
varArr = random.Value
Randomize
For X = 1 To UBound(varArr, 1)
    y = Int(Rnd() * UBound(varArr) + 1)
    varTemp = varArr(X, 1)
    varArr(X, 1) = varArr(y, 1)
    varArr(y, 1) = varTemp
Next X
random.Value = varArr
Next v
[a:a].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For i = 26 To 50
Controls("textbox" & i).Value = Sheets("OGLEN").Cells(i - 25, "a").Value
Next i

Dim oglensayi, eksik As Byte
oglensayi = WorksheetFunction.CountA(Range("a1:a30"))
eksik = 25 - oglensayi

For r = 1 To eksik
Controls("textbox" & (r + 50) - eksik).Value = Sheets("OGLEN").Cells(r, "a").Value & " (İKİNCİ NÖBET)"
Next r


End Sub

halit3 · 16 Temmuz 2017

veya bu kodu dene

Kod:

Sub sabahh()
Sheets("SABAH").Select
Dim varArr As Variant, varTemp As Variant
Dim random As Range
Dim X As Long, y As Long
'Dim say As Double
'say = Range("a65000").End(xlUp).Row
On Error Resume Next
'Set random = Sheets("NÖBET").Cells("a", say)
For z = 1 To 5
Set random = Sheets("SABAH").Range("A1:A30")
varArr = random.Value
Randomize
For X = 1 To UBound(varArr, 1)
    y = Int(Rnd() * UBound(varArr) + 1)
    varTemp = varArr(X, 1)
    varArr(X, 1) = varArr(y, 1)
    varArr(y, 1) = varTemp
Next X
random.Value = varArr
Next z
[a:a].SpecialCells(xlCellTypeBlanks).EntireRow.Delete

ReDim say1(1000)
For k = 1 To 2
For i = 1 To Worksheets("SABAH").Cells(Rows.Count, "a").End(3).Row
j = j + 1
If k = 1 Then
say1(j) = Sheets("SABAH").Cells(i, "a").Value
Else
say1(j) = Sheets("SABAH").Cells(i, "a").Value & " (İKİNCİ NÖBET)"
End If
Next i
Next k

For r = 1 To 25
Controls("textbox" & r).Value = say1(r)
Next r

End Sub
Sub oglenn()
Sheets("OGLEN").Select
Dim varArr As Variant, varTemp As Variant
Dim random As Range
Dim X As Long, y As Long
For v = 1 To 5
Set random = Sheets("OGLEN").Range("a1:a30")
varArr = random.Value
Randomize
For X = 1 To UBound(varArr, 1)
    y = Int(Rnd() * UBound(varArr) + 1)
    varTemp = varArr(X, 1)
    varArr(X, 1) = varArr(y, 1)
    varArr(y, 1) = varTemp
Next X
random.Value = varArr
Next v
[a:a].SpecialCells(xlCellTypeBlanks).EntireRow.Delete


ReDim say2(1000)
For k = 1 To 2
For i = 1 To Worksheets("OGLEN").Cells(Rows.Count, "a").End(3).Row
j = j + 1
If k = 1 Then
say2(j) = Sheets("OGLEN").Cells(i, "a").Value
Else
say2(j) = Sheets("OGLEN").Cells(i, "a").Value & " (İKİNCİ NÖBET)"
End If
Next i
Next k

For r = 26 To 50
Controls("textbox" & r).Value = say2(r - 25)
Next r


End Sub

ahmedummu · 16 Temmuz 2017

Halit bey elinize kolunuza sağlık çalıştı. Hayırlı akşamlar.

ahmedummu · 16 Temmuz 2017

Halit bey aşağıdaki koda da bakabilir misiniz.

Kod:

Private Sub ListBox3_Click()
TextBox1.Value = ListBox3.Value
Set rs = CreateObject("adodb.recordset")
rs.Open "select * from bilgiler where ADISOYADI='" & TextBox1.Text & "'", AdoCN, 1, 1
If rs.RecordCount > 0 Then
TextBox1.Text = rs("ADISOYADI").Value
TextBox2.Text = rs("TCNO").Value
End If
End Sub

Ekte gönderdiğim resimdeki hatayı veriyor.

halit3 · 16 Temmuz 2017

Bu kod diğerlerinden daha iyi geldi bana

Kod:

Private Sub CommandButton1_Click()
Call sabahh
Call oglenn
End Sub

Sub sabahh()

Dim i As Long, sayi As Long, say As Long, sut As Long
sayfa = "SABAH"
sut = 1
sayi = Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row

son = sayi
If sayi > son Then sayi = son
ReDim deg1(son)
ReDim deg2(son)

Randomize Timer
For i = 1 To sayi
atla:
say = Int((Rnd * son) + 1)
If Val(deg1(say)) = 0 Then
deg2(i) = Worksheets(sayfa).Cells(say, 1).Value
deg1(say) = 1
Else
GoTo atla
End If
Next i

For t = 1 To Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row
Sheets(sayfa).Cells(t, sut).Value = deg2(t)
Next t

ReDim say1(1000)

For k = 1 To 2
For m = 1 To Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row
j = j + 1
If k = 1 Then
say1(j) = Sheets(sayfa).Cells(m, sut).Value
Else
say1(j) = Sheets(sayfa).Cells(m, sut).Value & " (İKİNCİ NÖBET)"
End If
Next m
Next k

For r = 1 To 25
Controls("textbox" & r).Value = say1(r)
Next r

End Sub
Sub oglenn()


Dim i As Long, sayi As Long, say As Long, sut As Long
sayfa = "OGLEN"

sut = 1
sayi = Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row

son = sayi
If sayi > son Then sayi = son
ReDim deg1(son)
ReDim deg2(son)

Randomize Timer
For i = 1 To sayi
atla:
say = Int((Rnd * son) + 1)
If Val(deg1(say)) = 0 Then
deg2(i) = Worksheets(sayfa).Cells(say, 1).Value
deg1(say) = 1
Else
GoTo atla
End If
Next i

For t = 1 To Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row
Sheets(sayfa).Cells(t, sut).Value = deg2(t)
Next t

ReDim say1(1000)

For k = 1 To 2
For m = 1 To Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row
j = j + 1
If k = 1 Then
say1(j) = Sheets(sayfa).Cells(m, sut).Value
Else
say1(j) = Sheets(sayfa).Cells(m, sut).Value & " (İKİNCİ NÖBET)"
End If
Next m
Next k

For r = 26 To 50
Controls("textbox" & r).Value = say1(r - 25)
Next r

End Sub

Private Sub UserForm_Initialize()
TextBox51.Value = WorksheetFunction.CountA(Sheets("SABAH").Range("A1:A30"))
TextBox52.Value = WorksheetFunction.CountA(Sheets("OGLEN").Range("A1:A30"))
End Sub

BedriA · 16 Temmuz 2017

Tam emin değilim ama bu şekilde dener misiniz?

Kod:

Private Sub ListBox3_Click()
TextBox1.Value = ListBox3.Value
Set ba = CreateObject("adodb.recordset")
ba.Open "select * from bilgiler where ADISOYADI='" & TextBox1.Text & "'", AdoCN, 1, 1
If ba.RecordCount > 0 Then
TextBox1.Text = ba("ADISOYADI").Value
TextBox2.Text = ba("TCNO").Value
End If
End Sub

halit3 · 16 Temmuz 2017

ahmedummu' Alıntı:
Halit bey aşağıdaki koda da bakabilir misiniz.

Kod:

Private Sub ListBox3_Click() TextBox1.Value = ListBox3.Value Set rs = CreateObject("adodb.recordset") rs.Open "select * from bilgiler where ADISOYADI='" & TextBox1.Text & "'", AdoCN, 1, 1 If rs.RecordCount > 0 Then TextBox1.Text = rs("ADISOYADI").Value TextBox2.Text = rs("TCNO").Value End If End Sub

Ekte gönderdiğim resimdeki hatayı veriyor.

Konu ado olunca örnek dosyanı ekle bir bakalım genelde ben bu konularda pek cevap yazmıyorum ama dosyanı görmeden bir şey diyemem

ahmedummu · 17 Temmuz 2017

Dosyayı gönderiyorum Halit bey. Hata Userform2'de Listbox'tan ismi seçince hata veriyor.

ahmedummu · 17 Temmuz 2017

Teşekkür ederim BedriA bey yine aynı hatayı verdi.

halit3 · 17 Temmuz 2017

ahmedummu' Alıntı:
Dosyayı gönderiyorum Halit bey. Hata Userform2'de Listbox'tan ismi seçince hata veriyor.

Kırmızı bölümleri getirmemişsiniz herhangi bir değişkende tanımlı değil
kodu bu şekilde çalıştırın

Kod:

Private Sub ListBox3_Click()


[COLOR="Red"]Set AdoCN = CreateObject("ADODB.Connection")
Dosya_Yolu = ThisWorkbook.Path & "\veriler.mdb"
AdoCN.Provider = "Microsoft.Jet.OLEDB.4.0"
AdoCN.ConnectionString = Dosya_Yolu
AdoCN.Open
   [/COLOR]
TextBox1.Value = ListBox3.Value
Set RS = CreateObject("adodb.recordset")

RS.Open "select * from bilgiler where ADISOYADI='" & TextBox1.Text & "'", AdoCN, 1, 1
If RS.RecordCount > 0 Then
TextBox1.Text = RS("ADISOYADI").Value
TextBox2.Text = RS("TCNO").Value
End If
End Sub

ahmedummu · 17 Temmuz 2017

Çok teşekkürler Halit bey çalıştı.

ahmedummu · 17 Temmuz 2017

Birşey daha sormak istiyorum. Bu şekli ile tüm öğretmenleri listbox'a listeliyoruz Userform2 "Ücretli, Emekli Ücretli ve Sözleşmeli" öğretmenlerin işlerinin yapıldığı form. Listbox'a isimleri çekerken Veri Tabanından Sadece Alan adı STATU olan alandan alan adı,

ÜCRETLİ
EMEKLİ ÜCRETLİ
SÖZLEŞMELİ

Olanları listbox'a listeleyebilirmiyiz. STATU veri tabanında alanı 12 sütunda.

Textlere Veri Çekilmesi

ahmedummu

Misafir

Ekli dosyalar

halit3

Uzman

halit3

Uzman

ahmedummu

Misafir

ahmedummu

Misafir

Ekli dosyalar

halit3

Uzman

BedriA

halit3

Uzman

ahmedummu

Misafir

Ekli dosyalar

ahmedummu

Misafir

halit3

Uzman

ahmedummu

Misafir

ahmedummu

Misafir