Check Box İle Seçili Olan Sütunları Almak

[mustafa1205]

Örnek dosyamda açıklama yapmaya çalıştım. Veri tabanında bulunan bilgilerden check box ile sadece istediğim bilgilerin bulunduğu sütunları almak istiyorum. Check box dan ilgili sütunun seçimini yapıyorum. Ancak hep seçtiğim sütun check box undan bir sonraki sütunu veriyor. Kodda olan hatayı bulamadım. Umarım açıklayıcı olmuştur.

 

[muygun]

Merhaba;
Versiyon farkından dolayı dosyanızda çalışamadım.
Datalarınızı alarak farklı bir uygulama yaptım.
İnceleyin.
İyi çalışmalar.

 

[mustafa1205]

Muygun hocam günaydın. Mobilden yazmak durumunda kaldım. Kusura bakmayın. İş yerinde İnternet imkanımız yok. Akşam muhakkak size dönüş yapacağım. İcabında kodları da paylaşırım

 

[mustafa1205]

Muygun Hocam celedim. Versiyonunuz 2003 sanırım. Buda güzel olmuş. Ancak mevcut aşağıdaki kodda revize edebilir miyiz acaba ?

Sub SEÇİLİVERİLERİAKTAR()


Application.ScreenUpdating = False

Sheets("BİLGİ SEÇME SAYFASI").Select
Cells.Select
With Selection
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With



For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next

Dim SütunAdı As String
Set s1 = Sheets("BİLGİ SEÇME")
Set s2 = Sheets("BİLGİ SEÇME SAYFASI")
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "CheckBox" Then
If s1.Shapes(Picture.Name).OLEFormat.Object.Object = True Then
sat = Picture.BottomRightCell.Row
aranan = s1.Cells(sat, 1).Value
For i = 1 To s2.Cells(1, Columns.Count).End(xlToLeft).Column
If aranan = s2.Cells(1, i).Value Then
SütunAdı = Split(s2.Cells(1, i).Address, "$")(1)
sut = sut & "," & SütunAdı & ":" & SütunAdı
Exit For
End If
Next
End If
End If
End If
Next Picture

Range(Mid(sut, 2, Len(sut))).Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False



ActiveWorkbook.Application.Dialogs(xlDialogSaveAs).Show

ActiveWorkbook.Close False


Sheets("BİLGİ SEÇME SAYFASI").Visible = False
Sheets("BİLGİ SEÇME").Select
Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True





End Sub