Listbox'tan hücreye veri aktarma

asi_kartal · 16 Nisan 2012

slm arkadaşlar

excelde sayfa4 m sütunun da GEÇTİ yazanların isimleri sayfa1 de bulunan ListBox'a gelmesini, gelen isimlerin üzerine tıklayınca o isme ait Sayfa4'teki bilgilerin Sayfa1'deki boş yerlere aktarılmasını istiyorum. biraz karışık oldu ama inşallah derdimi anlatabilmişimdir.

Murat OSMA · 16 Nisan 2012

■ ThisWorkbook kod sayfasına;

Kod:

[SIZE="2"][FONT="Trebuchet MS"]Private Sub Workbook_Open()
    Dim i As Integer
    For i = 2 To Sayfa4.Range("M65536").End(3).Row
        If Sayfa4.Cells(i, "M") = "GEÇTİ" Then
            Sayfa1.ListBox1.AddItem Sayfa4.Cells(i, "C")
        End If
    Next i: i = Empty
End Sub[/FONT][/SIZE]

■ Sayfa1'in kod sayfasına;

Kod:

[SIZE="2"][FONT="Trebuchet MS"]Private Sub ListBox1_Click()
    Dim bul As Range
        For Each bul In Sayfa4.Range("C3:C" & Sayfa4.Range("C65536").End(3).Row)
            If bul.Value = Sayfa1.ListBox1.Value Then
                Range("E3").Value = bul.Offset(0, 1).Value
                Range("E4").Value = bul.Value
                Range("E5").Value = bul.Offset(0, 5).Value
                Range("E6").Value = bul.Offset(0, 6).Value
                Range("E7").Value = bul.Offset(0, 2).Value
                Range("E8").Value = bul.Offset(0, 3).Value
                Range("E9").Value = bul.Offset(0, 4).Value
                Range("H8").Value = bul.Offset(0, 8).Value
                Range("H9").Value = bul.Offset(0, 9).Value
            End If
        Next bul
    Set bul = Nothing
End Sub[/FONT][/SIZE]

Dosyayı da ekliyorum...

asi_kral · 16 Nisan 2012

asi_kartal' Alıntı:
slm arkadaşlar

excelde sayfa4 m sütunun da GEÇTİ yazanların isimleri sayfa1 de bulunan ListBox'a gelmesini, gelen isimlerin üzerine tıklayınca o isme ait Sayfa4'teki bilgilerin Sayfa1'deki boş yerlere aktarılmasını istiyorum. biraz karışık oldu ama inşallah derdimi anlatabilmişimdir.

Alternatif Olsun
Listbox'un Özellikler ( Properties ) ayarlarına girin. ListFillRange'nin karşısında yazan Adı_Soyadını silin.
Sayfanın kod bölümüne

Kod:

Option Explicit
Private Sub ListBox1_Click()
'Konu       :   Seçtiğim Kişilerin Bilgileri Gelsin
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Range, a As Variant
Set asi = Sheets("ÖĞRENCİ BİLGİLERİ")
Range("E3:E9,H8:H9").ClearContents
Set kral = asi.Range("C:C").Find(ListBox1, , , xlWhole)
If Not kral Is Nothing Then
a = kral.Address
Do
Range("E3") = asi.Cells(kral.Row, "D")
Range("E4") = asi.Cells(kral.Row, "C")
Range("E5") = asi.Cells(kral.Row, "H")
Range("E6") = asi.Cells(kral.Row, "I")
Range("E7") = asi.Cells(kral.Row, "E")
Range("E8") = asi.Cells(kral.Row, "F")
Range("E9") = asi.Cells(kral.Row, "G")
Range("H8") = asi.Cells(kral.Row, "K")
Range("H9") = asi.Cells(kral.Row, "L")
Set kral = asi.Range("C:C").FindNext(kral)
Loop While Not kral Is Nothing And kral.Address <> a
End If
End Sub
Private Sub Worksheet_Activate()
'Konu       :   Sayfa Aktif Olduğunda Listbox'a Geçenleri Listele
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Range, a As Variant
Set asi = Sheets("ÖĞRENCİ BİLGİLERİ")
ListBox1.Clear
Set kral = asi.Range("M:M").Find("GEÇTİ", , , xlWhole)
If Not kral Is Nothing Then
a = kral.Address
Do
ListBox1.AddItem asi.Cells(kral.Row, "C")
Set kral = asi.Range("M:M").FindNext(kral)
Loop While Not kral Is Nothing And kral.Address <> a
End If
End Sub

Bu Kodları kopyalayın ve deneyin.
Dosyanız Ekte.

asi_kartal · 16 Nisan 2012

Murat OSMA' Alıntı:

■ ThisWorkbook kod sayfasına;

Kod:

[SIZE="2"][FONT="Trebuchet MS"]Private Sub Workbook_Open()
    Dim i As Integer
    For i = 2 To Sayfa4.Range("M65536").End(3).Row
        If Sayfa4.Cells(i, "M") = "GEÇTİ" Then
            Sayfa1.ListBox1.AddItem Sayfa4.Cells(i, "C")
        End If
    Next i: i = Empty
End Sub[/FONT][/SIZE]

■ Sayfa1'in kod sayfasına;

Kod:

[SIZE="2"][FONT="Trebuchet MS"]Private Sub ListBox1_Click()
    Dim bul As Range
        For Each bul In Sayfa4.Range("C3:C" & Sayfa4.Range("C65536").End(3).Row)
            If bul.Value = Sayfa1.ListBox1.Value Then
                Range("E3").Value = bul.Offset(0, 1).Value
                Range("E4").Value = bul.Value
                Range("E5").Value = bul.Offset(0, 5).Value
                Range("E6").Value = bul.Offset(0, 6).Value
                Range("E7").Value = bul.Offset(0, 2).Value
                Range("E8").Value = bul.Offset(0, 3).Value
                Range("E9").Value = bul.Offset(0, 4).Value
                Range("H8").Value = bul.Offset(0, 8).Value
                Range("H9").Value = bul.Offset(0, 9).Value
            End If
        Next bul
    Set bul = Nothing
End Sub[/FONT][/SIZE]

Dosyayı da ekliyorum...

asi_kral_1967' Alıntı:

Alternatif Olsun
Listbox'un Özellikler ( Properties ) ayarlarına girin. ListFillRange'nin karşısında yazan Adı_Soyadını silin.
Sayfanın kod bölümüne

Kod:

Option Explicit
Private Sub ListBox1_Click()
'Konu       :   Seçtiğim Kişilerin Bilgileri Gelsin
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Range, a As Variant
Set asi = Sheets("ÖĞRENCİ BİLGİLERİ")
Range("E3:E9,H8:H9").ClearContents
Set kral = asi.Range("C:C").Find(ListBox1, , , xlWhole)
If Not kral Is Nothing Then
a = kral.Address
Do
Range("E3") = asi.Cells(kral.Row, "D")
Range("E4") = asi.Cells(kral.Row, "C")
Range("E5") = asi.Cells(kral.Row, "H")
Range("E6") = asi.Cells(kral.Row, "I")
Range("E7") = asi.Cells(kral.Row, "E")
Range("E8") = asi.Cells(kral.Row, "F")
Range("E9") = asi.Cells(kral.Row, "G")
Range("H8") = asi.Cells(kral.Row, "K")
Range("H9") = asi.Cells(kral.Row, "L")
Set kral = asi.Range("C:C").FindNext(kral)
Loop While Not kral Is Nothing And kral.Address <> a
End If
End Sub
Private Sub Worksheet_Activate()
'Konu       :   Sayfa Aktif Olduğunda Listbox'a Geçenleri Listele
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Range, a As Variant
Set asi = Sheets("ÖĞRENCİ BİLGİLERİ")
ListBox1.Clear
Set kral = asi.Range("M:M").Find("GEÇTİ", , , xlWhole)
If Not kral Is Nothing Then
a = kral.Address
Do
ListBox1.AddItem asi.Cells(kral.Row, "C")
Set kral = asi.Range("M:M").FindNext(kral)
Loop While Not kral Is Nothing And kral.Address <> a
End If
End Sub

Bu Kodları kopyalayın ve deneyin.
Dosyanız Ekte.

Çok teşekkür ederim. Allah razı olsun

asi_kral · 16 Nisan 2012

asi_kartal' Alıntı:
Çok teşekkür ederim. Allah razı olsun

Kolay Gelsin.

assenucler · 16 Nisan 2012

Sayın Murat Osma ve asi kral 1967;

Merhabalar... İyi haftalar ve bol kazançlar.

Bu güzel katkılarınız için teşekkürler.

Sevgi ve saygılar.

asi_kral · 16 Nisan 2012

assenucler' Alıntı:
Sayın Murat Osma ve asi kral 1967;

Merhabalar... İyi haftalar ve bol kazançlar.

Bu güzel katkılarınız için teşekkürler.

Sevgi ve saygılar.

Kolay Gelsin.

Talebeyiz · 19 Şubat 2014

listboxtan excele veri yazdırmak

Merhabalar listbox ta bulunan çok sütunlu verileri istediğimi seçip excel sayfasının a11 satırından başlayıp k11'e kadar eklemek; forumun başka bölümünde verilen kodları denedim ancak yapamadım yardımcı olursanız sevinirim
Dim s1 As Integer, sat As Long, sut As Long
Set s1 = Sheets("sayfa1")
sat = ListBox1.ListCount
sut = ListBox1.ColumnCount
s1.Range(s1.Cells(11, "A"), s1.Cells(sat + 3, sut + 1)) = ListBox1.List

birde verdiğiniz kodların ne anlama geldiğini anlatabilirmisiniz (set s1, sat ve sut satır ve sütun mu ifade eder) teşekkürler

Kullandığım versiyon office 2013 tür.

Murat OSMA · 20 Şubat 2014

Kodları bu şekilde kullanabilirsiniz;

Kod:

[FONT="Trebuchet MS"]Dim s1 As [COLOR="Red"]Worksheet[/COLOR], sat As integer, sut As integer
Set s1 = Sheets("Sayfa1")
sat = UBound(ListBox1.List, 1)
sut = UBound(ListBox1.List, 2)
s1.Range(s1.Cells([COLOR="red"]11[/COLOR], 1), s1.Cells([COLOR="red"]11[/COLOR] + sat, 1 + sut)).Value = ListBox1.List[/FONT]

Set s1 = Sheets("Sayfa1") = Sayfa1 isimli sayfanın adına kısaca s1 diyoruz.
sat = ListBox'taki verilerin son satır sayısını ifade eder ListBox1.ListCount -1 ile de aynı listelemeyi yapar.
sut = ListBox'taki verilerin son sütun sayısını ifade eder ListBox1.ColumnCount - 1 ile de aynı listelemeyi yapar.

Talebeyiz · 20 Şubat 2014

Murat OSMA bey çok teşekkür ederim vakit ayırıp ilgilendiniz sağolun

Murat OSMA · 20 Şubat 2014

Rica ederim, iyi günler.

Talebeyiz · 23 Şubat 2014

Listbox tan excele veri aktarma

Dim s1 As Worksheet, sat As integer, sut As integer
Set s1 = Sheets("Sayfa1")
sat = UBound(ListBox1.List, 1)
sut = UBound(ListBox1.List, 2)
s1.Range(s1.Cells(11, 1), s1.Cells(11 + sat, 1 + sut)).Value = ListBox1.List
Murat bey merhabalar bu vermiş olduğunuz kodlar listboxtan verileri excele aktarıyor ama listboxta bulunan tüm satırları seçsem veya seçmesemde excele aktarıyor listbox Multiselect özelliği 1 seçeneğinde; yani hangi satır veya birden çok satır seçiliyse o satırları eklemsini istiyorum seçili olmayan satırlar eklenmesin listbox1.selected denedim olmadı. Birde bu verileri a30 satırından ileriye daha fazla eklemesin uyarı versin" Liste sonuna geldiniz" diye çünkü veri aktarmak istediğim standart form ve a30 dan sonra imza bölümleri var yukardaki kodlarla veriler ekleniyor ve diğer standart bilgiler siliniyor sizi rahatsız ediyorum ancak çok uğraştım düzeltmek için olmadı vba için yeteri kadar bilgi birikimimde yok yardım ederseniz minnettar kalırım...

Murat OSMA · 27 Şubat 2014

Dosyanızı eklerseniz bakarım.

Talebeyiz · 27 Şubat 2014

Dosya ekleyemedim ekleme kısmını bulamadım veya kısıtlanmış teşekkürler Murat OSMA

Murat OSMA · 27 Şubat 2014

Google'a dosya upload yazıp listelenen sayfalardan birine yükleyin, indirme linkini de mesaja yazıp gönderin.

Talebeyiz · 28 Şubat 2014

kej23' Alıntı:
Dim s1 As Worksheet, sat As integer, sut As integer
Set s1 = Sheets("Sayfa1")
sat = UBound(ListBox1.List, 1)
sut = UBound(ListBox1.List, 2)
s1.Range(s1.Cells(11, 1), s1.Cells(11 + sat, 1 + sut)).Value = ListBox1.List
Murat bey merhabalar bu vermiş olduğunuz kodlar listboxtan verileri excele aktarıyor ama listboxta bulunan tüm satırları seçsem veya seçmesemde excele aktarıyor listbox Multiselect özelliği 1 seçeneğinde; yani hangi satır veya birden çok satır seçiliyse o satırları eklemsini istiyorum seçili olmayan satırlar eklenmesin listbox1.selected denedim olmadı. Birde bu verileri a30 satırından ileriye daha fazla eklemesin uyarı versin" Liste sonuna geldiniz" diye çünkü veri aktarmak istediğim standart form ve a30 dan sonra imza bölümleri var yukardaki kodlarla veriler ekleniyor ve diğer standart bilgiler siliniyor sizi rahatsız ediyorum ancak çok uğraştım düzeltmek için olmadı vba için yeteri kadar bilgi birikimimde yok yardım ederseniz minnettar kalırım...

http://dosya.co/xq634jlq3dyq/Deneme.xlsm.html

Murat bey çok teşekkür ederim dosyayı ekledim sizden ricam listboxtaki satırlardan hangisi veya hangileri seçili ise onları deneme sayfasının a11'den başlayarak yazsın listboxta satır veya satırlar seçili değilse seçim yapmadınız mesajı versin ve A30'u geçmesin a30'dan sonra liste sonuna geldiniz uyarısı versin ve ekleme yapmasın.

Birde combobox ve textboxlara format tanımlandığımda-Combobox1=format(combobox1,"#,##0.00")- 28,50 olan rakam 285,00 oluyor msgbox, label, Textbox, Combobok hepsinde aynı sorunu veriyor eklemiş olduğum dosyada comboboxtaki değeri label daki değere bölmesi istedim sonuç yanlış oluyor... Zaman ayırabilirseniz memnun olurum iyi çalışmalar.

Talebeyiz · 3 Mart 2014

Private Sub CommandButton4_Click()
Sheets("Sayfa1").Select
Dim s1 As Worksheet, Satir, X
Set s1 = Sheets("Sayfa1")
Satir = 11

On Error Resume Next
For X = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(X) = True Then
s1.Cells(Satir, 1) = Format(ListBox1.List(X, 0), "dd.mm.yyyy")
s1.Cells(Satir, 2) = ListBox1.List(X, 1)
s1.Cells(Satir, 3) = ListBox1.List(X, 2)
s1.Cells(Satir, 4) = ListBox1.List(X, 1)
s1.Cells(Satir, 5) = ListBox1.List(X, 4)
s1.Cells(Satir, 6) = ListBox1.List(X, 5)
s1.Cells(Satir, 7) = CDbl(ListBox1.List(X, 6))
s1.Cells(Satir, 8) = CDbl(ListBox1.List(X, 7))
s1.Cells(Satir, 9) = CDbl(ListBox1.List(X, 8))

Satir = Satir + 1
If Satir > 30 Then
MsgBox "Sayfa doldu. İşlem sonladırılmıştır.", vbCritical
GoTo 10
End If
End If
Next

10

Yukardaki kodlar Korhan Ayhan hocam tarafından düzeltilmiştir.

Emeği geçen Korhan Ayhan hocama çok teşekkür eder saygılarımı sunarım ve tüm emeği geçenlere böyle bir forum hazırlamada katkısı olan herkese

Murat OSMA bey teşekkürler sağolun

mr.akn · 24 Kasım 2016

Merhaba,

Seçili kısımları yazdırmak istiyorum ancak ilkini yazdırdıktan sonra seçili alanı temizlediği için devamını yazdıramıyor. Bu sorunu nasıl engellerim?
Dosyam aşağıdaki gibi; ikinci tablodan çoklu seçim yaparak düğme ile A sütununa yazdırma yapıyorum.

https://www.dropbox.com/s/51s664fnr67ngfq/Deneme.xlsm?dl=0

PLİNT · 24 Kasım 2016

mr.akn' Alıntı:
Merhaba,

Seçili kısımları yazdırmak istiyorum ancak ilkini yazdırdıktan sonra seçili alanı temizlediği için devamını yazdıramıyor. Bu sorunu nasıl engellerim?
Dosyam aşağıdaki gibi; ikinci tablodan çoklu seçim yaparak düğme ile A sütununa yazdırma yapıyorum.

Merhaba
Aslında listeden seçim yaptıkça direkt aktarabilirsiniz;
Dosyanızdaki gibi gerekli ise; "CommandButton1" altındaki kodları aşağıdaki gibi
deneyin:

Kod:

[SIZE="2"]Option Explicit
Private Sub CommandButton1_Click()
Dim intCounter As Integer
Dim StrValue As String
Dim i As Long
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
For intCounter = 0 To ComponentList.ListCount - 1
    If ComponentList.Selected(intCounter) = True Then
        StrValue = ComponentList.List(intCounter)
      dict.Add i, StrValue
    i = i + 1
    End If
Next
If i = 0 Then MsgBox "seçim yapınız": Exit Sub
Range("A:A").ClearContents
ActiveSheet.Range("a1").Resize(dict.Count).Value = _
Application.Transpose(dict.items)
End Sub[/SIZE]

mr.akn · 25 Kasım 2016

Çok teşekkürler PLİNT
Sorunu aşağıdaki gibi çözdüm ancak senin kodunu da inceleyip deneyeceğim.

Kod:

Private Sub CommandButton2_Click()
Dim intCounter As Integer
Dim ingCell As Long
Dim StrValue As String
Dim Secim(1 To 100) As String

ingCell = 2

For intCounter = 0 To TestList.ListCount - 1
    If TestList.Selected(intCounter) = True Then
        StrValue = TestList.List(intCounter)
'        Range("A" & ingCell) = StrValue
        Secim(ingCell) = StrValue
        ingCell = ingCell + 1
    End If
Next
Range("L2:L100").ClearContents
Dim z As Integer
For z = 2 To ingCell - 1
Range("L" & z) = Secim(z)
Next z
End Sub

Listbox'tan hücreye veri aktarma

asi_kartal

Ekli dosyalar

Murat OSMA

Altın Üye

Ekli dosyalar

asi_kral

Özel Üye

Ekli dosyalar

asi_kartal

asi_kral

Özel Üye

assenucler

asi_kral

Özel Üye

Talebeyiz

Murat OSMA

Altın Üye

Talebeyiz

Murat OSMA

Altın Üye

Talebeyiz

Murat OSMA

Altın Üye

Talebeyiz

Murat OSMA

Altın Üye

Talebeyiz

Talebeyiz

mr.akn

PLİNT

mr.akn