Skip to main content

AccessTr.neT


Özel Seçimli Liste Oluşturmak

Özel Seçimli Liste Oluşturmak

#19
Alttaki gibide biraz daha kod kısa olur.

Private Sub CommandButton16_Click()
Dim y As Byte, bulbaslikVeri As Range, bulveri As Range
Dim i As Long, deger As String
Dim syfVeri As Worksheet: Set syfVeri = ThisWorkbook.Sheets("VERÝ")
Dim syftasar As Worksheet: Set syftasar = ThisWorkbook.Sheets("TASARI")

With syftasar
    .Range(.Cells(1, 6), .Cells(Rows.Count, Columns.Count)).ClearContents
    y = 6
    For x = 6 To 14
        deger = Me.Controls("ComboBox" & x).Value
        If Trim(deger) <> "" Then
            .Cells(1, y).Value = deger
            i = 2
            Do While .Cells(i, 2).Value <> ""
                Set bulveri = syfVeri.Columns(2).Find(.Cells(i, "B").Value, , xlValues, 1)
                Set bulbaslikVeri = syfVeri.Rows(1).Find(deger, , , , 1)
                If Not bulbaslikVeri Is Nothing Then _
                .Cells(i, y).Value = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)
                i = i + 1
            Loop
            y = y + 1
        End If
    Next x
End With
syftasar.Cells.EntireColumn.AutoFit
syftasar.Cells.EntireRow.AutoFit
Set bulbaslikVeri = Nothing: Set bulveri = Nothing
Set syfVeri = Nothing: Set syftasar = Nothing
End Sub
Cevapla
#20
Öncekiler yavaş olursa alttaki kullanılabilir.

Private Sub CommandButton16_Click()
Dim y As Byte, bulbaslikVeri As Range, bulveri As Range, xx As Byte
Dim i As Long, deger As String, arr(), say As Byte, sonTasr As Long
Dim syfVeri As Worksheet: Set syfVeri = ThisWorkbook.Sheets("VERÝ")
Dim syftasar As Worksheet: Set syftasar = ThisWorkbook.Sheets("TASARI")

Const comboSayisi_ilk As Byte = 6
Const comboSayisi_son As Byte = 14

say = 0
For x = comboSayisi_ilk To comboSayisi_son
    If Me.Controls("ComboBox" & x).Value <> "" Then say = say + 1
Next

If say = 0 Then
    MsgBox "combolardan secim yap...", vbCritical, "Hata"
    Exit Sub
End If

With syftasar
    If WorksheetFunction.CountA(.Range("A2:A" & Rows.Count)) = 0 Then
        MsgBox " Tasari sayfasinda vaeri yok...", vbCritical, "Hata"
        Exit Sub
    Else
        sonTasr = .Cells(Rows.Count, 1).End(3).Row
        ReDim arr(1 To sonTasr, 1 To say)
    End If

    .Range(.Cells(1, comboSayisi_ilk), .Cells(Rows.Count, Columns.Count)).ClearContents
    y = comboSayisi_ilk
    Application.ScreenUpdating = False
    For x = comboSayisi_ilk To comboSayisi_son
        deger = Me.Controls("ComboBox" & x).Value
        If Trim(deger) <> "" Then
            .Cells(1, y).Value = deger
            i = 1
            Do While .Cells(i, 2).Value <> ""
                Set bulveri = syfVeri.Columns(2).Find(.Cells(i + 1, "B").Value, , xlValues, 1)
                Set bulbaslikVeri = syfVeri.Rows(1).Find(deger, , , , 1)
                If Not bulbaslikVeri Is Nothing Then
                    For xx = 1 To say
                        arr(i, xx) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)
                    Next
                End If
                i = i + 1
            Loop
            syftasar.Cells(2, y).Resize(UBound(arr), 1).Value = arr
            y = y + 1
        End If
    Next x
    Application.ScreenUpdating = True
    MsgBox "Bitti"
    Erase arr
End With
syftasar.Cells.EntireColumn.AutoFit
syftasar.Cells.EntireRow.AutoFit
Set bulbaslikVeri = Nothing: Set bulveri = Nothing
Set syfVeri = Nothing: Set syftasar = Nothing
End Sub

Doğru çalışırsaki bende çalıştı en ideal ve hızlısı bu oldu.

Private Sub CommandButton16_Click()
Dim y As Byte, bulbaslikVeri As Range, bulveri As Range, xx As Byte
Dim i As Long, deger As String, arr(), say As Byte, sonTasr As Long, veri
Dim syfVeri As Worksheet: Set syfVeri = ThisWorkbook.Sheets("VERİ")
Dim syftasar As Worksheet: Set syftasar = ThisWorkbook.Sheets("TASARI")

Const comboSayisi_ilk As Byte = 6
Const comboSayisi_son As Byte = 14

say = 0
For x = comboSayisi_ilk To comboSayisi_son
    If Me.Controls("ComboBox" & x).Value <> "" Then say = say + 1
Next

If say = 0 Then
    MsgBox "combolardan secim yap...", vbCritical, "Hata"
    Exit Sub
End If

With syftasar
    If WorksheetFunction.CountA(.Range("A2:A" & Rows.Count)) = 0 Then
        MsgBox " Tasari sayfasinda veri yok...", vbCritical, "Hata"
        Exit Sub
    Else
        sonTasr = .Cells(Rows.Count, 1).End(3).Row
        ReDim arr(1 To sonTasr, 1 To say)
    End If

    .Range(.Cells(1, comboSayisi_ilk), .Cells(Rows.Count, Columns.Count)).ClearContents
    y = comboSayisi_ilk
    Application.ScreenUpdating = False
    For x = comboSayisi_ilk To comboSayisi_son
        deger = Me.Controls("ComboBox" & x).Value
        If Trim(deger) <> "" Then
            .Cells(1, y).Value = deger
            i = 1
            veri = .Range("B2:B" & sonTasr).Value
            For i = 1 To UBound(veri)
                Set bulveri = syfVeri.Columns(2).Find(veri(i, 1), , xlValues, 1)
                Set bulbaslikVeri = syfVeri.Rows(1).Find(deger, , , , 1)
                If Not bulbaslikVeri Is Nothing Then
                    For xx = 1 To say
                        arr(i, xx) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)
                    Next xx
                End If
            Next
            syftasar.Cells(2, y).Resize(UBound(arr), 1).Value = arr
            y = y + 1
        End If
    Next x
    Application.ScreenUpdating = True
    MsgBox "Bitti"
    Erase arr: Erase veri
End With
syftasar.Cells.EntireColumn.AutoFit
syftasar.Cells.EntireRow.AutoFit
Set bulbaslikVeri = Nothing: Set bulveri = Nothing
Set syfVeri = Nothing: Set syftasar = Nothing
End Sub
Cevapla
#21
Zafer Hocam elinize kolunuza sağlık kod aşırı hızlı çalışıyor
Eliniz dert görmesin Hocam

yalnız comboboxlar tasarı sayfasındaki sütun harflerine göre veriyi atsa
Mesela F sutunu comboboxuna bürosunu seçiyorum
N sütunu comboboxuna cep telefonunu seçiyorum olması gereken Sayfayı hazırla butonuna basınca F ve N sütunlarında karşılığının bulunup gelmesi ama
N sütunu için comboboxta seçilen değer aradaki boş olması gereken sütunları boş bırakmadan G sütununs yazıyor.
Hocam arada boş sütun olursa olsun hangi sütuna ait combobox seçilirse  sütunun altında sıralansa daha iyi olmaz olmaz mı
Cevapla
#22
(17/04/2021, 11:44)hayalibey yazdı: Zafer Hocam elinize kolunuza sağlık kod aşırı hızlı çalışıyor
Eliniz dert görmesin Hocam

yalnız comboboxlar tasarı sayfasındaki sütun harflerine göre veriyi atsa
Mesela F sutunu comboboxuna bürosunu seçiyorum
N sütunu comboboxuna cep telefonunu seçiyorum olması gereken Sayfayı hazırla butonuna basınca F ve N sütunlarında karşılığının bulunup gelmesi ama
N sütunu için comboboxta seçilen değer aradaki boş olması gereken sütunları boş bırakmadan G sütununs yazıyor.
Hocam arada boş sütun olursa olsun hangi sütuna ait combobox seçilirse  sütunun altında sıralansa daha iyi olmaz olmaz mı
Sayfada örnek olarak gösterirmisiniz sonucu
Cevapla
#23
(17/04/2021, 11:47)feraz yazdı:
(17/04/2021, 11:44)hayalibey yazdı: Zafer Hocam elinize kolunuza sağlık kod aşırı hızlı çalışıyor
Eliniz dert görmesin Hocam

yalnız comboboxlar tasarı sayfasındaki sütun harflerine göre veriyi atsa
Mesela F sutunu comboboxuna bürosunu seçiyorum
N sütunu comboboxuna cep telefonunu seçiyorum olması gereken Sayfayı hazırla butonuna basınca F ve N sütunlarında karşılığının bulunup gelmesi ama
N sütunu için comboboxta seçilen değer aradaki boş olması gereken sütunları boş bırakmadan G sütununs yazıyor.
Hocam arada boş sütun olursa olsun hangi sütuna ait combobox seçilirse  sütunun altında sıralansa daha iyi olmaz olmaz mı
Sayfada örnek olarak gösterirmisiniz sonucu
Hocam ekran görüntüsünü ekledim gerçek bilgilerin olduğu alanı kararttım
.rar Adsız.rar (Dosya Boyutu: 46,33 KB | İndirme Sayısı: 1)
Cevapla
#24
Resimdeki gibi yolladığınız resim için sütunlar aynı değil yanlışmı?Mesela F sütunlarındaki sütun adları farklı hangisi olacak?

[Resim: do.php?img=10915]
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task