Skip to main content

AccessTr.neT

Kayıt Ol

 | Facebook ile Bağlan  | Twitter İle Bağlan | Google+ İle Bağlan

Özel Seçimli Liste Oluşturmak

hayalibey
hayalibey
Excel Cevaplanmış Soruları
33
2156

Özel Seçimli Liste Oluşturmak

#31
feraz
Uzman
feraz
Bul
Uzman
Adı Soyadı: Za....
Yaşı: 47
Konum: -
Ofis Versiyonu: Diğer
Son Oturumu: Bugün,03:16
Yorumları: 3.637
Konuları: 95
Kayıt Tarihi: 30/03/2013
Teşekkür Puanı: 316
Delille ispatladım abey Img-grin

[Resim: xxxx.gif]
Ben veri sayfası ve tasarı sayfası eşit olacak zannettim galiba olay farklı halledince kodu eklerim.
Cevapla
#32
feraz
Uzman
feraz
Bul
Uzman
Adı Soyadı: Za....
Yaşı: 47
Konum: -
Ofis Versiyonu: Diğer
Son Oturumu: Bugün,03:16
Yorumları: 3.637
Konuları: 95
Kayıt Tarihi: 30/03/2013
Teşekkür Puanı: 316
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
#33
hayalibey
Aktif Üye
hayalibey
Bul
Aktif Üye
Adı Soyadı:
Konum:
Ofis Versiyonu:
Son Oturumu: 05/10/2023,17:05
Yorumları: 250
Konuları: 30
Kayıt Tarihi: 30/01/2013
Teşekkür Puanı: 0
(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.
Cevapla
#34
feraz
Uzman
feraz
Bul
Uzman
Adı Soyadı: Za....
Yaşı: 47
Konum: -
Ofis Versiyonu: Diğer
Son Oturumu: Bugün,03:16
Yorumları: 3.637
Konuları: 95
Kayıt Tarihi: 30/03/2013
Teşekkür Puanı: 316
(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.
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task