Soru Checkbox'a göre sütun silme

Gkhnozn · 19 Eylül 2022

Öncelikle merhabalar, bir proje üzerinde çalışıyorum ve bir yerde takıldım çıldırmak üzereyim. Lütfen yardım.
İstediğim şey şu: Bir filtreleme işlemi gerçekleştiriyorum ve neticesinde bu filtrelediğim verileri istediğim bir klasöre aktarıyorum. Fakat aktarırken listbox içerisinde hangi kolonların yazdırılmasını checkbox'lar yardımıyla seçmek istiyorum. Ekteki çalışmamda göreceğiniz üzere yaptığım şey önce bütün sütunları eklemek ve seçmediğim checkboxa göre o seçmediklerimi excelden silmek, seçtiklerimin ise kalmasını sağlamak. Lakin yapmak istediğim işlem sağlıklı sonuç vermiyor. Lütfen Yardım. Teşekkür ederim şimdiden.

Harici Link:

İndir EXCEL FİLTRELEME

Dosyayı indir EXCEL FİLTRELEME

dosya.co

Gkhnozn · 19 Eylül 2022

Sorunu buldum fakat çözümüne ulaşamıyorum. Sorun şu ben Checkbox1 isaretli degilse A sutununu sil diyorum checkbox2 isaretli degilse B sutunu sil diyorum ve bu sirayla 17 ye kadar devam ediyor. Fakat diyelim A silindi bu kez benim b dedigim aslinda c sutununa denk geliyor A silinip sütun kaydığı için. Bunu nasil engelleyebilirim, yani checkbox1 isaretli degilse A sutunu, checkbox2 isaretli degilse b sutunu, checkbox3 isaretli degilse c sutunu diye devam ederek silmek istiyorum. Yardim lütfen.

Gkhnozn · 19 Eylül 2022

Yanlışlıkla şifreli göndermişim. Kusura bakmayın.
Şifre: gokhan0641

Korhan Ayhan · 20 Eylül 2022

Merhaba,

Normalde silme işlemlerinde mantığı ters kurmalısınız. Yani sondan başa doğru ilerlemelisiniz. Bu durumda silme işleminde kayma problemi yaşamazsınız.

Ben olsam silmek yerine atlanacak sütunları veri aktarımında es geçme yöntemini denerdim. Sizin için daha basit olabilir.

Gkhnozn · 20 Eylül 2022

Bu dediğiniz atlama işlemini nasıl yapacağım acaba, bilgi verebilir misiniz?

Korhan Ayhan · 20 Eylül 2022

Verileri başka dosyaya aktarırken kullandığınız koda if (eğer) sorguları eklemelisiniz.

Gkhnozn · 21 Eylül 2022

Hocam rica etsem kodumu degistirmeden checkboxa göre listboxtan değer alma işini yapabilir misiniz ? Ne kadar ugrassam da olmuyor ve sütun silme işi çok yavaslatiyor programimi. Teşekkür ederim

Korhan Ayhan · 21 Eylül 2022

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim File_Name  As String, My_Folder As Variant, X As Long
    Dim My_Sheet As Worksheet, My_Check As Boolean, My_Count As Byte
    Dim My_Box As Object, My_Area As Range, Last_Row As Long
    
10  If My_Count = 3 Then
        MsgBox "Çok Fazla Deneme Yaptınız!" & vbCrLf & vbCrLf & _
               "Lütfen Daha Sonra Tekrar Deneyiniz.", vbExclamation, "Veri Aktarma Hatası"
        Exit Sub
    End If
    
    File_Name = InputBox("Lütfen Aktarmak İstediğiniz Dosyanın Adını Giriniz.", "DOSYA ADI")
    
    If File_Name = "" Then
           MsgBox "Filtrelediğiniz Verinlerin Aktarılması İçin Dosya Adı Belirlemelisiniz!", vbCritical, "Veri Aktarma Hatası"
           Exit Sub
    End If

    If My_Check = False Then
        Set My_Folder = CreateObject("Shell.Application").BrowseForFolder(0, _
        "Lütfen Aktarımını Yapmak İstediğiniz Dosyanın Kaydedileceği Klasörü Seçiniz.", &H100)
    End If
      
    If Not My_Folder Is Nothing Then
        If Dir(My_Folder.Self.Path & "\" & File_Name & ".xlsx") <> "" Then
            My_Count = My_Count + 1
            If My_Count < 3 Then
                MsgBox "Verileri Aktarmak İstediğiniz Klasörde Aynı İsimle Başka Bir Dosya Bulunuyor!" & vbCrLf & vbCrLf & _
                " Lütfen Farklı Bir Dosya Adı Giriniz!", vbCritical
                My_Check = True
                GoTo 10
            ElseIf My_Count = 3 Then
                GoTo 10
            End If
        End If
    
        Sheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = "FİLTRELEME"
        
        Set My_Sheet = Sheets("FİLTRELEME")
        
        With My_Sheet
            .Cells.ClearContents
            Last_Row = .Cells(.Rows.Count, 1).End(3).Row + 1
            .Cells(Last_Row, 1).Resize(FILTRELEME.ListBox1.ListCount, FILTRELEME.ListBox1.ColumnCount) = FILTRELEME.ListBox1.List
            .Cells(Last_Row, 1).Resize(FILTRELEME.ListBox1.ListCount, FILTRELEME.ListBox1.ColumnCount).Borders.LineStyle = 1

            Application.PrintCommunication = False
            With ActiveSheet.PageSetup
                .LeftHeader = ""
                .CenterHeader = ""
                .RightHeader = ""
                .LeftFooter = ""
                .CenterFooter = ""
                .RightFooter = ""
                .LeftMargin = Application.InchesToPoints(0)
                .RightMargin = Application.InchesToPoints(0)
                .TopMargin = Application.InchesToPoints(0)
                .BottomMargin = Application.InchesToPoints(0)
                .HeaderMargin = Application.InchesToPoints(0)
                .FooterMargin = Application.InchesToPoints(0)
                .PrintHeadings = False
                .PrintGridlines = False
                .PrintComments = xlPrintNoComments
                .PrintQuality = 600
                .CenterHorizontally = True
                .CenterVertically = False
                .Orientation = xlLandscape
                .Draft = False
                .PaperSize = xlPaperA4
                .FirstPageNumber = xlAutomatic
                .Order = xlDownThenOver
                .BlackAndWhite = False
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1000
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = True
                .EvenPage.LeftHeader.Text = ""
                .EvenPage.CenterHeader.Text = ""
                .EvenPage.RightHeader.Text = ""
                .EvenPage.LeftFooter.Text = ""
                .EvenPage.CenterFooter.Text = ""
                .EvenPage.RightFooter.Text = ""
                .FirstPage.LeftHeader.Text = ""
                .FirstPage.CenterHeader.Text = ""
                .FirstPage.RightHeader.Text = ""
                .FirstPage.LeftFooter.Text = ""
                .FirstPage.CenterFooter.Text = ""
                .FirstPage.RightFooter.Text = ""
            End With
            Application.PrintCommunication = True
            
            .Range("A1:Q1").MergeCells = True
            
            .Cells.Font.Name = "Times New Roman"
            .Cells.Font.Size = 12
            .Cells.VerticalAlignment = xlCenter
            .Cells.HorizontalAlignment = xlCenter
            .Cells.WrapText = True
            .Range("A1:A2").EntireRow.Font.Bold = True
            .Range("A:B").ColumnWidth = 50
            .Range("C:E").ColumnWidth = 22
            .Range("F:H").ColumnWidth = 12
            .Range("I:I").ColumnWidth = 15
            .Range("J:K").ColumnWidth = 100
            .Range("L:L").ColumnWidth = 60
            .Range("M:M").ColumnWidth = 13
            .Range("N:O").ColumnWidth = 80
            .Range("P:P").ColumnWidth = 25
            .Range("Q:Q").ColumnWidth = 13
            .Columns.AutoFit
            .Rows.AutoFit
            
            For Each My_Box In Me.Controls
                If TypeName(My_Box) = "CheckBox" Then
                    If My_Box.Value = False And My_Box.Caption <> "tümü" Then
                        If My_Area Is Nothing Then
                            Set My_Area = .Cells(1, Val(Replace(My_Box.Name, "CheckBox", "")))
                        Else
                            Set My_Area = Union(My_Area, .Cells(1, Val(Replace(My_Box.Name, "CheckBox", ""))))
                        End If
                    End If
                End If
            Next
                
            If Not My_Area Is Nothing Then My_Area.EntireColumn.Delete
        
            .Range("A1").Value = FILTRELEME.TextBox1.Text & "-" & FILTRELEME.TextBox2.Text & _
                                 " TARİHLERİ ARASINDAKİ " & FILTRELEME.C1.Text & " ANA MALZEMESİNE AİT ARIZALAR"
        End With
            
        Application.ScreenUpdating = False
        My_Sheet.Copy
        ActiveWorkbook.SaveAs My_Folder.Self.Path & "\" & File_Name & ".xlsx", xlOpenXMLWorkbook, Local:=True
        ActiveWorkbook.Close False
        Application.DisplayAlerts = False
        ActiveSheet.Delete
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Sheets("AGBF").Activate
        MsgBox "Filtrelediğiniz Veriler " & My_Folder.Self.Path & " Klasörüne " & File_Name & " İsmiyle Kaydedilmiştir.", vbInformation, "Veri Aktarma"
        Set My_Area = Nothing
        Set My_Sheet = Nothing
        Set My_Folder = Nothing
    Else
        MsgBox "Klasör Seçimi Yapmadığınız İçin Veri Aktarım İşlemi Gerçekleştirilemedi.", vbCritical, "Veri Aktarma Hatası"
    End If
End Sub

Gkhnozn · 21 Eylül 2022

Hocam elinize sağlık çok güzel çalıştı, yalnız excelin içerisinde düzenleme yapmak istiyorum. Nereye yazarsam yazayim tam olarak istediğim sonucu alamoyorum.
Şunları yapmak istiyorum:

Yazı tipi: Times new roman
Boyutu: 12
Yatay ve dikeyde ortalama
Birinci ve ikinci satir bold
Tum sayfa metni kaydir
A ve B sutunu genisligi 50
CDE sütunları 22
FGH sütunları 12
I sutunu 15
JK sutunlari 100
L sutunu 60
M sutunu 13
NO sutunlari 80
P sutunu 25
Q sutunu ise 13

Satirda da autofit
olsun istiyorum.

Rica etsem bunları bu kod bloguna uygulayabilir misiniz? Zahmet veriyorum farkindayim fakat cok memnun kalacagim.

Teşekkür ederim.

Korhan Ayhan · 21 Eylül 2022

Üstteki mesajımda ki kodda bazı revizeler yaptım. Bu hali daha derli toplu oldu. Deneyiniz.

Gkhnozn · 22 Eylül 2022

Hocam birşey söylemeyi unutmuşum k.bakmayin. Bir de gelen verilerde baslik kısmı haric kenarlik olsun istiyorum. Verdiğiniz kod çok iyi çalıştı fakat sadece 1.checkbox secili degilken yani birinci sütunu eklemek istemediğimde baslik kısmı ona bağlı olduğu için siliniyor.
Bu konularda da yardımcı olabilirseniz sevinirim. Cok teşekkür ederim

Gkhnozn · 22 Eylül 2022

Kenarligi hallettim hocam sadece diğer problem kaldi.

Korhan Ayhan · 22 Eylül 2022

Üstte ki mesajımdaki kodu son taleplerinize göre tekrar revize ettim. Deneyiniz.

Veri aktarma işleminde kullanılan döngüyü iptal ettim. Yerine daha hızlı bir kod kullandım. Bu haliyle daha iyi performans verecektir.

Gkhnozn · 22 Eylül 2022

Hocam harikasınız çok teşekkür ederim.

Gkhnozn · 22 Eylül 2022

Hocam inanın sizi bulmuşken surekli sorasim geliyor k.bakmayin ama size iki sorum olacaktı.

Birincisi benim yaptığım programda excele tıklıyorum fakat excel acilmadan userform açılıyor ve islemlerimi gerceklestiriyorum. Fakat bazen onceden acik bir excel varsa kendi userformum ordan veri cekiyor. Bunu engellemenin bir yolu var mıdır. Yani benim excelime tikladigim an ne acik olursa olsun farketmeksizin en ustte benim excelim olsun ve oradan veri ceksin istiyorum. Bu mümkün mü?

Digeri ise daha önce forumda sordum fakat kimseden cevap alamadigim sorum. Şu ki:
Comboboxa bir listeden veri alıyorum örneğin aldigim veriler ali, veli, ahmet vs olsun. Ben combo icine l harfini girince comboboxı filtreleyerek bana sadece l harfini iceren verileri yani ali ve veliyi versin istiyorum. Bu mümkün mü?

Yardımcı olabilirseniz çok sevinirim.
Teşekkür ederim.

Korhan Ayhan · 22 Eylül 2022

Anladığım kadarıyla exceli gizleyip kullanıyorsunuz. Bu durumda aşağıdaki kod satırlarını tek tek deneyebilirsiniz. Hangisi işinize yararsa onu kullanabilirsiniz.

2. ve 3. yöntemde tırnak içindeki bölüme kendi dosya adınızı yazmalısınız.

1. Yöntem;

C++:

Private Sub UserForm_Initialize()
    ThisWorkbook.Activate
    Rem Diğer kodlarınız...
End Sub

2. Yöntem;

C++:

Private Sub UserForm_Initialize()
    Windows("Kitap1.xlsm").Activate
    Rem Diğer kodlarınız...
End Sub

3. Yöntem;

C++:

Private Sub UserForm_Initialize()
    Workbooks("Kitap1.xlsm").Activate
    Rem Diğer kodlarınız...
End Sub

Diğer sorunuzu için ekteki dosyayı inceleyiniz.

Gkhnozn · 23 Eylül 2022

Hocam inanın nasıl teşekkür etsem bilemiyorum. Allah razı olsun.

Gkhnozn · 23 Eylül 2022

Private Sub UserForm_Initialize()
On Error Resume Next

For X = 7 To Worksheets("AGBF").Cells(10000, 3).End(xlUp).Row
If WorksheetFunction.CountIf(Range("C2:C" & X), Cells(X, 3)) = 1 Then
ComboBox10.AddItem Cells(X, 3).Value
End If
Next

For a = LBound(ComboBox10.List) To UBound(ComboBox10.List) - 1
For b = a + 1 To UBound(ComboBox10.List)
If ComboBox10.List(b) < ComboBox10.List(a) Then
X = ComboBox10.List(a)
ComboBox10.List(a) = ComboBox10.List(b)
ComboBox10.List(b) = X
End If
Next
Next
End sub

Private Sub ComboBox10_Change()
On Error Resume Next

TextBox7.Value = Empty
TextBox8.Value = Empty
TextBox9.Value = Empty
TextBox15.Value = Empty

Dim Veri As Variant, X As Long, Say As Long, Liste As Variant

If Me.ComboBox10 <> "" Then
Me.ComboBox10.RowSource = Empty
Veri = Sheets("AGBF").Range("C7:C10000").Value
ReDim Liste(1 To 1)
For X = LBound(Veri) To UBound(Veri)
If UCase(Replace(Replace(Veri(X, 1), "ı", "I"), "i", "İ")) Like _
"*" & UCase(Replace(Replace(Me.ComboBox10.Value, "ı", "I"), "i", "İ")) & "*" Then
Say = Say + 1
ReDim Preserve Liste(1 To Say)
Liste(Say) = Veri(X, 1)
End If
Next
Me.ComboBox10.List = Liste
Me.ComboBox10.DropDown
Else
Call UserForm_Initialize
End If

ComboBox10 = Evaluate("=upper(""" & ComboBox10 & """)")
End Sub

Hocam verdiğinizi kendi çalışmama uyarladım fakat veriler teke düşmüyor ve ilk harfi silince çok yavaş hareket ediyor. Nedeni nedir acaba?

Gkhnozn · 25 Eylül 2022

Korhan Ayhan · 25 Eylül 2022

Önceki mesajımdaki örnek dosyayı revize ettim. Tekrar deneyiniz.

Soru Checkbox'a göre sütun silme

Gkhnozn

İndir EXCEL FİLTRELEME

Gkhnozn

Gkhnozn

Korhan Ayhan

Administrator

Gkhnozn

Korhan Ayhan

Administrator

Gkhnozn

Korhan Ayhan

Administrator

Gkhnozn

Korhan Ayhan

Administrator

Gkhnozn

Gkhnozn

Korhan Ayhan

Administrator

Gkhnozn

Gkhnozn

Korhan Ayhan

Administrator

Ekli dosyalar

Gkhnozn

Gkhnozn

Gkhnozn

Korhan Ayhan

Administrator