Özel Seçimli Liste Oluşturmak

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

Ö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

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ı

(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

(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

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?