253 Sütun için checkbox işlemleri

[asterix1234]

Merhaba,

Ekteki örnekte; Listview bilgileri "Bilgiler" sayfasından alarak "sonuç" sayfasına topluyor ve burada userform1 sayesinde kolonlara göre süzme işlemini yapıyorum ve listviewde görüntülüyorum.

Userform2 oluşturdum, amacı listviewde süzülen verilerin (253 kolon) checkboxlar sayesinde seçim yaparak ("sonuç" sayfasını baz alıyorum) istediğim kolonları işaretleyip seçilen kolonları süzülen veriler ile yeni bir sayfaya atıyorum/atamıyorum

Saçma ve baya uzun bir kod yazdım bu iş için 253 kolonu içeren (yaparken biliyordum saçma olduğunu ama öğrenmek için denedim) bu kodlar usewrform2 deki excele aktar butonu içerisinde. Aktarım şu şekilde oluyor; listviewde istediğim kriterdeki bilgileri listeledikten sonra checkboxlar ile kolon seçiyorum yaptığım seçime göre "sonuç" sayfasından sadece gözükeni kopyala özelliği ile kopyalama yapıp, kodlar ile yeni bir sayfa açıyorum ve buraya yapıştırıyorum.


Sorun1. her kolon için checkbox oluşturduğumdan ve ayrıca kod yazıldığından çok uzun bir kod oluyor ve tahminimce gereksiz yere yazılmış kodlar bu kodları sadeleştirmem gerekli...

Sorun2. seçtiğim kolonlar çok farklı olabilir. Örn. A,DB,GW kolonlarını seçtiğimi düşünürsek bunları yapıştırdığımda aralarında baya bir boşluk oluyor. Bu kolonları nasıl yan yana kolon boşluğu olmadan birleştiririz.


Umarım anlatabilmişimdir. Örnek Ekte
Yardımlarınız için şimdiden teşekkür ederim............

 

[asterix1234]

Help Meeeeeeeeee

 

[asterix1234]

Help Meeeeee

 

[Orion1]

2nci grup 3ncü grup 4ncü grup bunlar ne olacak?

Ayrıca 1nci grupta isimler CheckBox1001-CheckBox2002..n diye olsun
2nci grupta isimler CheckBox2001-CheckBox2002.......n diye olsun
3ncü gruptata CheckBox30001-CheckBox3002.......n diye olsun
4ncü gruptada 4001 ile başlasın

 

[asterix1234]

2nci grup 3ncü grup 4ncü grup bunlar ne olacak?

Ayrıca 1nci grupta isimler CheckBox1001-CheckBox2002..n diye olsun
2nci grupta isimler CheckBox2001-CheckBox2002.......n diye olsun
3ncü gruptata CheckBox30001-CheckBox3002.......n diye olsun
4ncü gruptada 4001 ile başlasın

Hocam 1. grup yada 2. grup diye devam eden butonlar hagi guruba aitse tümünü seçecek

mesela 1. grup butonuna bastığımızda 1 grupta yeralan atıyorum 1 ile 100 arasındaki checkboxların tamamını işretliyecek.

esas sorun ise excele aktar butonunda seçtiğim tüm checkboxlara ait kolonları yeni açılacak boş bir sayfaya bitişik olarak aktaracak.

bu arada günaydın.

 

[Orion1]

Dosyanız ekte.

Private Sub CommandButton6_Click()
Dim sut As Byte, i As Byte, satir As Boolean, j As Long
On Error Resume Next
If MsgBox("Onaylıyorsanız, Seçmiş Olduğunuz Kriterlerdeki Bilgiler [ sonuc ] sayfasına Aktarılacaktır.", vbYesNo + vbQuestion, "AKTARMA") = vbNo Then Exit Sub
If UserForm1.ListView1.ListItems.Count < 1 Then
    MsgBox "Listview'de Aktarılacak veri yok..!!", vbCritical, "UYARI"
    Exit Sub
End If
Set s2 = Sheets("AKTARMA")
Application.ScreenUpdating = False
s2.Range("A1:IT65536").ClearContents
sat = 1
With UserForm1.ListView1
    For i = 1 To 253
        If Controls("CheckBox" & i).Value = True Then
            sut = sut + 1
            s2.Cells(1, sut).Value = Controls("CheckBox" & i).Caption
        End If
    Next i
    For j = 1 To .ListItems.Count
        sut = 0
        satir = False
        If CheckBox1.Value = True Then
            sut = sut + 1
            sat = sat + 1
            satir = True
            s2.Cells(sat, sut).Value = .ListItems(j)
        End If
        For i = 2 To 253
            If Controls("CheckBox" & i).Value = True Then
                sut = sut + 1
                If satir = False Then
                    sat = sat + 1
                    satir = True
                End If
                s2.Cells(sat, sut).Value = .ListItems(j).SubItems(i - 1)
            End If
        Next i
    Next j
End With
Set s2 = Nothing
Application.ScreenUpdating = True
If sat > 1 Then MsgBox "Aktarma Yapıldı..!!", vbOKOnly + vbInformation, "AKTARMA"
End Sub

 

[asterix1234]

Evren Hocam, nediyebilirm ki Allah Razı olsun...

hocam, ben aynı excel dosyasına değilde desktopa atılan, atıyorum xxxx adında bir dosyaya aktarılmasını düşünmüştüm olmaz mı ?

yani herkesin userformun bulunduğu excel dosyasını kurcalamasını istemem

çok sağolun KARŞILIKSIZ emeğinizi nasıl öderim bilemiyorum...

 

[Orion1]

Evren Hocam, nediyebilirm ki Allah Razı olsun...

hocam, ben aynı excel dosyasına değilde desktopa atılan, atıyorum xxxx adında bir dosyaya aktarılmasını düşünmüştüm olmaz mı ?

yani herkesin userformun bulunduğu excel dosyasını kurcalamasını istemem

çok sağolun KARŞILIKSIZ emeğinizi nasıl öderim bilemiyorum...

VBA'ya şifre koyun.

 

[asterix1234]

VBA'ya şifre koyun.

vba ya ve excel açılışına şifre koyacağım hocam ama, dediğim gibi desktopa bir excel dosyayı oluşturup ona atsak süperrr olurdu olma ihitmali varmı ? yaparmıyız hocam ?

 

[Orion1]

vba ya ve excel açılışına şifre koyacağım hocam ama, dediğim gibi desktopa bir excel dosyayı oluşturup ona atsak süperrr olurdu olma ihitmali varmı ? yaparmıyız hocam ?

Arama.xls isminde bir tane excel dosyası oluşturun.
Bir sayfasının adını Arama Koyun.
Bu dosyayı Ve kullandığınız dosyayı ayni klasörün içine koyun(Sonra kısa yolunu masa üstüne çıkarabilirsiniz).
Dosya kullanıma hazırdır.
Aşağıdaki kodu Userform2'de commandbutton6_click olayına yapıştırın.

Dim sut As Byte, i As Byte, satir As Boolean, j As Long
On Error Resume Next
If MsgBox("Onaylıyorsanız, Seçmiş Olduğunuz Kriterlerdeki Bilgiler [ sonuc ] sayfasına Aktarılacaktır.", vbYesNo + vbQuestion, "AKTARMA") = vbNo Then Exit Sub
If UserForm1.ListView1.ListItems.Count < 1 Then
    MsgBox "Listview'de Aktar&#305;lacak veri yok..!!", vbCritical, "UYARI"
    Exit Sub
End If
If Dir(ThisWorkbook.Path & "\Arama.xls") = "" Then
    MsgBox "[ " & ThisWorkbook.Path & "\Arama.xls ] Dosyas&#305; bulunamd&#305;.", vbCritical, "UYARI"
    Exit Sub
End If
Application.DisplayAlerts = False
If Workbooks.Open(ThisWorkbook.Path & "\Arama.xls").ReadOnly = True Then
    Workbooks("Arama.xls").Close False
End If
Set s2 = Workbooks("Arama.xls").Sheets("ARAMA")
Application.ScreenUpdating = False
s2.Range("A1:IT65536").ClearContents
sat = 1
With UserForm1.ListView1
    For i = 1 To 253
        If Controls("CheckBox" & i).Value = True Then
            sut = sut + 1
            s2.Cells(1, sut).Value = Controls("CheckBox" & i).Caption
        End If
    Next i
    For j = 1 To .ListItems.Count
        sut = 0
        satir = False
        If CheckBox1.Value = True Then
            sut = sut + 1
            sat = sat + 1
            satir = True
            s2.Cells(sat, sut).Value = .ListItems(j)
        End If
        For i = 2 To 253
            If Controls("CheckBox" & i).Value = True Then
                sut = sut + 1
                If satir = False Then
                    sat = sat + 1
                    satir = True
                End If
                s2.Cells(sat, sut).Value = .ListItems(j).SubItems(i - 1)
            End If
        Next i
    Next j
End With
Set s2 = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Workbooks("Arama.xls").Close True
If sat > 1 Then MsgBox "Aktarma Yap&#305;ld&#305;..!!", vbOKOnly + vbInformation, "AKTARMA"