Özel Seçimli Liste Oluşturmak

1 2 3 4 5 6

Delille ispatladım abey

Ben veri sayfası ve tasarı sayfası eşit olacak zannettim galiba olay farklı halledince kodu eklerim.

Abey bukez oldu istediğiniz bence.



Private Sub CommandButton16_Click()

Dim bulbaslikVeri As Range, bulveri As Range

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 (comboSayisi_son - comboSayisi_ilk) + 1)

    End If



    .Range(.Cells(1, comboSayisi_ilk), .Cells(Rows.Count, Columns.Count)).ClearContents



    Application.ScreenUpdating = False

    For x = comboSayisi_ilk To comboSayisi_son

        deger = Me.Controls("ComboBox" & x).Value

        If Trim(deger) <> "" Then

            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, , xlValues, 1)

                If Not bulbaslikVeri Is Nothing Then _

                        arr(i, comboSayisi_ilk - (comboSayisi_ilk - 1)) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)

            Next

            Select Case x

                Case 6: syftasar.Cells(2, "F").Resize(UBound(arr), 1).Value = arr: .Cells(1, "F").Value = deger

                Case 7: syftasar.Cells(2, "g").Resize(UBound(arr), 1).Value = arr: .Cells(1, "g").Value = deger

                Case 8: syftasar.Cells(2, "h").Resize(UBound(arr), 1).Value = arr: .Cells(1, "h").Value = deger

                Case 9: syftasar.Cells(2, "i").Resize(UBound(arr), 1).Value = arr: .Cells(1, "i").Value = deger

                Case 10: syftasar.Cells(2, "j").Resize(UBound(arr), 1).Value = arr: .Cells(1, "j").Value = deger

                Case 11: syftasar.Cells(2, "k").Resize(UBound(arr), 1).Value = arr: .Cells(1, "k").Value = deger

                Case 12: syftasar.Cells(2, "L").Resize(UBound(arr), 1).Value = arr: .Cells(1, "L").Value = deger

                Case 13: syftasar.Cells(2, "m").Resize(UBound(arr), 1).Value = arr: .Cells(1, "m").Value = deger

                Case 14: syftasar.Cells(2, "n").Resize(UBound(arr), 1).Value = arr: .Cells(1, "n").Value = deger

            End Select

        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

(17/04/2021, 19:55)feraz yazdı: Abey bukez oldu istediğiniz bence.



Private Sub CommandButton16_Click()

Dim bulbaslikVeri As Range, bulveri As Range

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 (comboSayisi_son - comboSayisi_ilk) + 1)

    End If



    .Range(.Cells(1, comboSayisi_ilk), .Cells(Rows.Count, Columns.Count)).ClearContents



    Application.ScreenUpdating = False

    For x = comboSayisi_ilk To comboSayisi_son

        deger = Me.Controls("ComboBox" & x).Value

        If Trim(deger) <> "" Then

            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, , xlValues, 1)

                If Not bulbaslikVeri Is Nothing Then _

                        arr(i, comboSayisi_ilk - (comboSayisi_ilk - 1)) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)

            Next

            Select Case x

                Case 6: syftasar.Cells(2, "F").Resize(UBound(arr), 1).Value = arr: .Cells(1, "F").Value = deger

                Case 7: syftasar.Cells(2, "g").Resize(UBound(arr), 1).Value = arr: .Cells(1, "g").Value = deger

                Case 8: syftasar.Cells(2, "h").Resize(UBound(arr), 1).Value = arr: .Cells(1, "h").Value = deger

                Case 9: syftasar.Cells(2, "i").Resize(UBound(arr), 1).Value = arr: .Cells(1, "i").Value = deger

                Case 10: syftasar.Cells(2, "j").Resize(UBound(arr), 1).Value = arr: .Cells(1, "j").Value = deger

                Case 11: syftasar.Cells(2, "k").Resize(UBound(arr), 1).Value = arr: .Cells(1, "k").Value = deger

                Case 12: syftasar.Cells(2, "L").Resize(UBound(arr), 1).Value = arr: .Cells(1, "L").Value = deger

                Case 13: syftasar.Cells(2, "m").Resize(UBound(arr), 1).Value = arr: .Cells(1, "m").Value = deger

                Case 14: syftasar.Cells(2, "n").Resize(UBound(arr), 1).Value = arr: .Cells(1, "n").Value = deger

            End Select

        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 emeğinize sağlık . Allah sizden razı olsun. Kod sorunsuz çalıştı. Çok teşekkür ederim.

(17/04/2021, 22:49)hayalibey yazdı:

(17/04/2021, 19:55)feraz yazdı: Abey bukez oldu istediğiniz bence.



Private Sub CommandButton16_Click()

Dim bulbaslikVeri As Range, bulveri As Range

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 (comboSayisi_son - comboSayisi_ilk) + 1)

    End If



    .Range(.Cells(1, comboSayisi_ilk), .Cells(Rows.Count, Columns.Count)).ClearContents



    Application.ScreenUpdating = False

    For x = comboSayisi_ilk To comboSayisi_son

        deger = Me.Controls("ComboBox" & x).Value

        If Trim(deger) <> "" Then

            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, , xlValues, 1)

                If Not bulbaslikVeri Is Nothing Then _

                        arr(i, comboSayisi_ilk - (comboSayisi_ilk - 1)) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)

            Next

            Select Case x

                Case 6: syftasar.Cells(2, "F").Resize(UBound(arr), 1).Value = arr: .Cells(1, "F").Value = deger

                Case 7: syftasar.Cells(2, "g").Resize(UBound(arr), 1).Value = arr: .Cells(1, "g").Value = deger

                Case 8: syftasar.Cells(2, "h").Resize(UBound(arr), 1).Value = arr: .Cells(1, "h").Value = deger

                Case 9: syftasar.Cells(2, "i").Resize(UBound(arr), 1).Value = arr: .Cells(1, "i").Value = deger

                Case 10: syftasar.Cells(2, "j").Resize(UBound(arr), 1).Value = arr: .Cells(1, "j").Value = deger

                Case 11: syftasar.Cells(2, "k").Resize(UBound(arr), 1).Value = arr: .Cells(1, "k").Value = deger

                Case 12: syftasar.Cells(2, "L").Resize(UBound(arr), 1).Value = arr: .Cells(1, "L").Value = deger

                Case 13: syftasar.Cells(2, "m").Resize(UBound(arr), 1).Value = arr: .Cells(1, "m").Value = deger

                Case 14: syftasar.Cells(2, "n").Resize(UBound(arr), 1).Value = arr: .Cells(1, "n").Value = deger

            End Select

        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 emeğinize sağlık . Allah sizden razı olsun. Kod sorunsuz çalıştı. Çok teşekkür ederim.

Sizdende abey Amin.Kolay gelsin.

1 2 3 4 5 6