Re: Özel Seçimli Liste Oluşturmak - feraz - 16/04/2021
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
Re: Özel Seçimli Liste Oluşturmak - feraz - 16/04/2021
Ayrıca If sonsat < 3 Then Exit Sub yerine If sonsat = 1 Then Exit Sub olmalı.
Son eklediğim kodda düzeltin abey.
RE: Özel Seçimli Liste Oluşturmak - hayalibey - 16/04/2021
(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
RE: Özel Seçimli Liste Oluşturmak - feraz - 16/04/2021
Tamam abey bakacağım bugün
RE: Özel Seçimli Liste Oluşturmak - hayalibey - 16/04/2021
Çok teşekkür ederim Hocam
Re: Özel Seçimli Liste Oluşturmak - feraz - 17/04/2021
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
|