Özel Seçimli Liste Oluşturmak

Normalde Kaydet alttaki gibi olmalı.

Private Sub Kaydet_Click()



Dim VeriSyf  As Worksheet, son As Long

Set VeriSyf = Sheets("TASARI")

    VeriSyf.Cells.Clear

    VeriSyf.[a1] = "SN"

    VeriSyf.[B1] = "Sicili"

    VeriSyf.[c1] = "Adý"

    VeriSyf.[D1] = "Soy Adý"

    VeriSyf.[e1] = "Rütbesi"

    With ListBox2

        If .ListCount = 0 Then Exit Sub

        For a = 0 To .ListCount - 1

            son = VeriSyf.Range("A" & Rows.Count).End(3).Row + 1

            VeriSyf.Range("A" & son).Value = .list(a, 0)

            VeriSyf.Range("B" & son).Value = .list(a, 1)

            VeriSyf.Range("C" & son).Value = .list(a, 2)

            VeriSyf.Range("D" & son).Value = .list(a, 3)

            VeriSyf.Range("E" & son).Value = .list(a, 4)

        Next a

    End With

    a = Empty





'Rütbeye Göre Sýrala



    sonsat = VeriSyf.Cells(Rows.Count, 1).End(3).Row

    If sonsat < 3 Then Exit Sub

    Application.ScreenUpdating = False

    VeriSyf.Range("A2", "A" & sonsat - 1).FormulaR1C1 = "=MATCH(RC[4],KONTROL!C[1],0)"

    VeriSyf.Range("A2", "A" & sonsat - 1).Value = VeriSyf.Range("A2", "A" & sonsat - 1).Value

    VeriSyf.Range("A2:N" & sonsat).Sort Key1:=VeriSyf.[a2], Order1:=xlAscending, Key2:=VeriSyf.[B2], ORder2:=xlAscending

    VeriSyf.Range("A2").Value = "1"

    VeriSyf.Range("A2", "A" & sonsat).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False

    Application.ScreenUpdating = True



    With VeriSyf.Rows(1).Font

        .Name = "Times New Roman"

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .TintAndShade = 0

        .ThemeFont = xlThemeFontNone

        .Color = vbRed

    End With

    

    '''''''''''''''''''''''''''' 1. Satýra Baþlýk Eklemek '''''''''''''''''''''''''''''''''''''''''''''



    'tüm Sütünü eþit aralýkta yapar

VeriSyf.Cells.EntireColumn.AutoFit



'tüm Satýrý eþit aralýkta yapar

VeriSyf.Cells.EntireRow.AutoFit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set VeriSyf = Nothing

MsgBox "aktarildi"

End Sub

Ayrıca If sonsat < 3 Then Exit Sub yerine If sonsat = 1 Then Exit Sub olmalı.
Son eklediğim kodda düzeltin abey.

(16/04/2021, 19:10)feraz yazdı: Ayrıca If sonsat < 3 Then Exit Sub yerine If sonsat = 1 Then Exit Sub olmalı.
Son eklediğim kodda düzeltin abey.

Hocam düzenlemeyi kaydet butonunun altına ekledim.
Şimdi A:E aralığına gelen veri için ComboBoxlarda F sütunundan başlayarak N sütununa kadar seçtiğim verinin karşısına o veriye ait seçilen bilgiyi bularak comboboxta seçilen ismini de 1. satırlara gelecek şekilde getirmesi gerekiyor.

Bu kodu Sayfayı hazırla commandbttonunun altına eklemeyi düşünüyorum Hocam.
Yardımlarınızı bekliyorum

Tamam abey bakacağım bugün

Çok teşekkür ederim Hocam

Rica ederim.
Eğer veri sayfası Sicil sütunu benzersiz ise alttaki kodu kullanın abey.

Private Sub CommandButton16_Click()



Dim y As Byte, bulbaslikTasar As Range, 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

            Set bulbaslikTasar = .Rows(1).Find(deger, , xlValues, 1)

            If Not bulbaslikTasar Is Nothing Then

                i = 2

                Do While .Cells(i, 2).Value <> ""

                    Set bulveri = syfVeri.Columns(2).Find(.Cells(i, "B").Value, , xlValues, 1)

                     If Not bulbaslikTasar Is Nothing Then

                        Set bulbaslikVeri = syfVeri.Rows(1).Find(deger, , , , 1)

                        If Not bulbaslikVeri Is Nothing Then

                            .Cells(i, bulbaslikTasar.Column).Value = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)

                        End If

                     End If

                    i = i + 1

                Loop

            End If

                        

            Set bulbaslikTasar = Nothing

            y = y + 1

        End If

    Next x

End With

syftasar.Cells.EntireColumn.AutoFit

syftasar.Cells.EntireRow.AutoFit

Set bulbaslikTasar = Nothing: Set bulbaslikVeri = Nothing: Set bulveri = Nothing

Set syfVeri = Nothing: Set syftasar = Nothing



End Sub