Skip to main content

AccessTr.neT


Özel Seçimli Liste Oluşturmak

Özel Seçimli Liste Oluşturmak

#32
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
.rar Özel Listeden Sıralama.rar (Dosya Boyutu: 64,38 KB | İndirme Sayısı: 4)
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da

Bu Konudaki Yorumlar
Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 15/04/2021, 15:48
RE: Özel Seçimli Liste Oluşturmak - Yazar: userx - 15/04/2021, 17:16
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 16/04/2021, 13:54
Re: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 15/04/2021, 23:26
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 16/04/2021, 02:41
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 16/04/2021, 04:15
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 16/04/2021, 05:14
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 16/04/2021, 13:40
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 16/04/2021, 15:28
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 16/04/2021, 17:06
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 16/04/2021, 18:12
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 16/04/2021, 18:45
Re: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 16/04/2021, 18:59
Re: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 16/04/2021, 19:10
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 16/04/2021, 20:27
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 16/04/2021, 21:54
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 16/04/2021, 22:04
Re: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 00:18
Re: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 01:06
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 03:01
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 17/04/2021, 11:44
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 11:47
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 17/04/2021, 11:59
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 12:24
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 17/04/2021, 12:29
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 12:36
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 17/04/2021, 12:40
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 13:28
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 17/04/2021, 17:07
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 19:05
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 19:16
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 19:55
RE: Özel Seçimli Liste Oluşturmak - Yazar: hayalibey - 17/04/2021, 22:49
RE: Özel Seçimli Liste Oluşturmak - Yazar: feraz - 17/04/2021, 23:14