Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Excel'e Yeni Başlayanlar
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Excel'e Yeni Başlayanlar Excel kullanmaya yeni başladıysanız sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 16-07-2017, 19:47   #1
ahmedummu
Altın Üye
 
ahmedummu kullanıcısının avatarı
 
Giriş: 21/06/2009
Şehir: Ankara
Mesaj: 119
Excel Vers. ve Dili:
2003 türkçe
Varsayılan Textlere Veri Çekilmesi

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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.
Eklenmiş Dosyalar
Dosya Türü: xls örnek.xls (66.5 KB, 7 Görüntülenme)

Bu mesaj en son " 16-07-2017 " tarihinde saat 19:54 itibariyle ahmedummu tarafından düzenlenmiştir.... Neden: Eksik bilgi
ahmedummu Çevrimdışı   Alıntı Yaparak Cevapla
Eski 16-07-2017, 20:40   #2
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,301
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

kodu şöyle birdene bakalım

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 16-07-2017, 21:29   #3
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,301
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

veya bu kodu dene

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 16-07-2017, 21:31   #4
ahmedummu
Altın Üye
 
ahmedummu kullanıcısının avatarı
 
Giriş: 21/06/2009
Şehir: Ankara
Mesaj: 119
Excel Vers. ve Dili:
2003 türkçe
Varsayılan

Halit bey elinize kolunuza sağlık çalıştı. Hayırlı akşamlar.
ahmedummu Çevrimdışı   Alıntı Yaparak Cevapla
Eski 16-07-2017, 21:36   #5
ahmedummu
Altın Üye
 
ahmedummu kullanıcısının avatarı
 
Giriş: 21/06/2009
Şehir: Ankara
Mesaj: 119
Excel Vers. ve Dili:
2003 türkçe
Varsayılan

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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.
Eklenmiş Resimler
Dosya Türü: jpg hata.jpg (23.8 KB, 4 Görüntülenme)
ahmedummu Çevrimdışı   Alıntı Yaparak Cevapla
Eski 16-07-2017, 21:47   #6
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,301
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Bu kod diğerlerinden daha iyi geldi bana

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 16-07-2017, 21:48   #7
BedriA
Altın Üye
 
Giriş: 03/06/2017
Şehir: Antalya
Mesaj: 446
Excel Vers. ve Dili:
2007, 32
Varsayılan

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________
Mutluluğun kodunu yazabilir misin Abidin?
BedriA Çevrimdışı   Alıntı Yaparak Cevapla
Eski 16-07-2017, 21:49   #8
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,301
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Alıntı:
ahmedummu tarafından gönderildi Mesajı Görüntüle
Halit bey aşağıdaki koda da bakabilir misiniz.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 17-07-2017, 07:39   #9
ahmedummu
Altın Üye
 
ahmedummu kullanıcısının avatarı
 
Giriş: 21/06/2009
Şehir: Ankara
Mesaj: 119
Excel Vers. ve Dili:
2003 türkçe
Varsayılan

Dosyayı gönderiyorum Halit bey. Hata Userform2'de Listbox'tan ismi seçince hata veriyor.
Eklenmiş Dosyalar
Dosya Türü: rar DataRam.rar (166.6 KB, 6 Görüntülenme)
ahmedummu Çevrimdışı   Alıntı Yaparak Cevapla
Eski 17-07-2017, 07:42   #10
ahmedummu
Altın Üye
 
ahmedummu kullanıcısının avatarı
 
Giriş: 21/06/2009
Şehir: Ankara
Mesaj: 119
Excel Vers. ve Dili:
2003 türkçe
Varsayılan

Teşekkür ederim BedriA bey yine aynı hatayı verdi.
ahmedummu Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 02:48


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - investing - Hurda - Kozmetik Ürünler - Sağlıklı Makyaj Ürünleri - Yaşlanma Karşıtı Ürünler - Excel Eğitimi - Çorlu osgb - Lingerie - Dyeing Machine - Çorlu Temizlik- Hazır Site- SEO- Çorlu Burun Estetiği- Çorlu Pimapen- Karton Bardak- Marka Tescil Danışmanlık- Marmara Ereğlisi Restaurant- Çorlu Sigorta- Çorlu Pimapenci- İstanbul Avukat- Çorlu Sürücü Kursu- Çorlu Rehabilitasyon- Edirne Su Arıtma- Çorlu Perde Yıkama- Marmara Ereğlisi Hotel- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden