Özel Seçimli Liste Oluşturmak

Özel Seçimli Liste Oluşturmak - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Özel Seçimli Liste Oluşturmak (/konu-ozel-secimli-liste-olusturmak.html)

Sayfalar: 1 2 3 4 5 6

RE: Özel Seçimli Liste Oluşturmak - hayalibey - 17/04/2021

(17/04/2021, 12:24)feraz yazdı: Resimdeki gibi yolladığınız resim için sütunlar aynı değil yanlışmı?Mesela F sütunlarındaki sütun adları farklı hangisi olacak?

Hocam başlıklar veri sayfası ve tasarı sayfası için birebir aynı.
Tasarı sayfasınaveri çekerken veri sayfasındaki ilgili başlığı da kontrol edecek
Siciller ve başlıklar harfi harfine aynı bendeki dosyada

RE: Özel Seçimli Liste Oluşturmak - feraz - 17/04/2021

(17/04/2021, 12:29)hayalibey yazdı:
(17/04/2021, 12:24)feraz yazdı: Resimdeki gibi yolladığınız resim için sütunlar aynı değil yanlışmı?Mesela F sütunlarındaki sütun adları farklı hangisi olacak?

Hocam başlıklar veri sayfası ve tasarı sayfası için birebir aynı.
Tasarı sayfasınaveri çekerken veri sayfasındaki ilgili başlığı da kontrol edecek
Siciller ve başlıklar harfi harfine aynı bendeki dosyada

Tamam abey yolladığınız dosyada aynı değildi galiba anladım halledince dosayı eklerim inşAllah.

RE: Özel Seçimli Liste Oluşturmak - hayalibey - 17/04/2021

(17/04/2021, 12:36)feraz yazdı:
(17/04/2021, 12:29)hayalibey yazdı:
(17/04/2021, 12:24)feraz yazdı: Resimdeki gibi yolladığınız resim için sütunlar aynı değil yanlışmı?Mesela F sütunlarındaki sütun adları farklı hangisi olacak?

Hocam başlıklar veri sayfası ve tasarı sayfası için birebir aynı.
Tasarı sayfasınaveri çekerken veri sayfasındaki ilgili başlığı da kontrol edecek
Siciller ve başlıklar harfi harfine aynı bendeki dosyada
Tamam abey yolladığınız dosyada aynı değildi galiba anladım halledince dosayı eklerim inşAllah.

Tamam Hocam çok teşekkür ederim

RE: Özel Seçimli Liste Oluşturmak - feraz - 17/04/2021

Rica ederim abey bir iki satır değiştirdim deneyin.

Private Sub CommandButton16_Click()

Dim bulbaslikVeri As Range, bulveri As Range, xx As Byte

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 say)

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

                If Not bulbaslikVeri Is Nothing Then

                    For xx = 1 To say

                        arr(i, xx) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)

                    Next xx

                End If

            Next

            .Cells(1, bulbaslikVeri.Column).Value = deger

            syftasar.Cells(2, bulbaslikVeri.Column).Resize(UBound(arr), 1).Value = arr



        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

RE: Özel Seçimli Liste Oluşturmak - hayalibey - 17/04/2021

(17/04/2021, 13:28)feraz yazdı: Rica ederim abey bir iki satır değiştirdim deneyin.

Private Sub CommandButton16_Click()

Dim bulbaslikVeri As Range, bulveri As Range, xx As Byte

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 say)

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

                If Not bulbaslikVeri Is Nothing Then

                    For xx = 1 To say

                        arr(i, xx) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)

                    Next xx

                End If

            Next

            .Cells(1, bulbaslikVeri.Column).Value = deger

            syftasar.Cells(2, bulbaslikVeri.Column).Resize(UBound(arr), 1).Value = arr



        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

Hocam malesef ilgili sütun için ComBoBoxta seçilen veri TASARI sayfasında farklı sütuna geliyor malesef

RE: Özel Seçimli Liste Oluşturmak - feraz - 17/04/2021

(17/04/2021, 17:07)hayalibey yazdı:

(17/04/2021, 13:28)feraz yazdı: Rica ederim abey bir iki satır değiştirdim deneyin.

Private Sub CommandButton16_Click()

Dim bulbaslikVeri As Range, bulveri As Range, xx As Byte

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 say)

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

                If Not bulbaslikVeri Is Nothing Then

                    For xx = 1 To say

                        arr(i, xx) = syfVeri.Cells(bulveri.Row, bulbaslikVeri.Column)

                    Next xx

                End If

            Next

            .Cells(1, bulbaslikVeri.Column).Value = deger

            syftasar.Cells(2, bulbaslikVeri.Column).Resize(UBound(arr), 1).Value = arr



        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

Hocam malesef ilgili sütun için ComBoBoxta seçilen veri TASARI sayfasında farklı sütuna geliyor malesef

Farklı gelmesi imkansız abey Img-grin

Don dosyanızı ekleyin bakayım bir.