[Yardım]  Aynı değerlere sahip sütunu silme

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

Aynı değerlere sahip sütunu silme

İleti#1)  Elvish » 26 Ekm 2020 12:15

Herkese merhaba,
şu konuda yardım almak istiyorum;

Tablodaki sütunlardan herhangi birisi veya bir kaç tanesi baştan aşağıya aynı değere sahipse o sütun silinsin istiyorum.

Şimdiden teşekkür ederim
Kullanıcı avatarı
Elvish
Yeni Başlamış
 
Kayıt: 26 Ekm 2020 12:09
Meslek: Öğrenci
Yaş: 27
İleti: 10
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir

Cevap: Aynı değerlere sahip sütunu silme

İleti#2)  vkonca » 26 Ekm 2020 15:24

Excel üst menüden
VERİ -> Yinelenenleri Kaldır

seçeneğini kullanabilirsin
Web and Desktop Developer
Kullanıcı avatarı
vkonca
Yeni Başlamış
 
Kayıt: 16 Oca 2020 09:38
Meslek: Bilgi İşlem
Yaş: 24
İleti: 68
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: TEKİRDAĞ

Cevap: Aynı değerlere sahip sütunu silme

İleti#3)  Elvish » 26 Ekm 2020 15:49

vkonca yazdı:Excel üst menüden
VERİ -> Yinelenenleri Kaldır

seçeneğini kullanabilirsin


bi proje için kod lazım o yüzden böyle yapmak zorundayım :/
Kullanıcı avatarı
Elvish
Yeni Başlamış
 
Kayıt: 26 Ekm 2020 12:09
Meslek: Öğrenci
Yaş: 27
İleti: 10
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir

Cevap: Aynı değerlere sahip sütunu silme

İleti#4)  okutkan » 27 Ekm 2020 01:14

Bu veriler hangi aralıkta olacak, sadece sayılardan mı oluşuyor?
Şu mantık ile yapsanız; a1 ile a5 hücreleri arasındaki sayıları kontrol edelim.

A1:4
A2:4
A3:4
A4:4
A5:4

5 hücrenin toplamı alınır ve 5'e bölünür. Çıkan Sonuç A1 hücresine eşit ise sütun silinir, eğer çıkan sonuç A1 hücresinden büyük veya küçük ise işlem yapılmaz.

Hücrelerden herhangi birinin bile farklı olması sonucunda sütunun silinmeyeceği koşuluna göre bu mantık ile işlem yapılabilir. Eğer 5'e bölündüğünde çıkan ortalama herhangi birine eşit değilse işlem yapılmaz.
Kullanıcı avatarı
okutkan
Yeni Başlamış
 
Kayıt: 27 May 2017 02:45
Meslek: pol. mem.
Yaş: 28
İleti: 99
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: DENİZLİ

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: Aynı değerlere sahip sütunu silme

İleti#5)  Miraç CAN » 27 Ekm 2020 11:14

Deneyin:
Kod: Tümünü seç
Sub DeleteColumns()
Dim FrstCl&, ScndCl&, FrstEndRw&
Dim EndClmn&, Rw&, Eql As Boolean
EndClmn = [A1].End(2).Column
Do
    FrstCl = FrstCl + 1: ScndCl = FrstCl
    FrstEndRw = Cells(Rows.Count, FrstCl).End(3).Row
    Do
        ScndCl = ScndCl + 1
        If FrstEndRw = Cells(Rows.Count, ScndCl).End(3).Row Then
            For Rw = 1 To FrstEndRw
                If Not Cells(Rw, FrstCl) Like Cells(Rw, ScndCl) Then Eql = True: Exit For
            Next Rw
            If Not Eql Then Columns(ScndCl).Delete: EndClmn = EndClmn - 1: ScndCl = ScndCl - 1
            Eql = False
        End If
    Loop While ScndCl < EndClmn
Loop While FrstCl < EndClmn - 1
End Sub
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 803
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

Cevap: Aynı değerlere sahip sütunu silme

İleti#6)  Elvish » 27 Ekm 2020 17:41

okutkan yazdı:Bu veriler hangi aralıkta olacak, sadece sayılardan mı oluşuyor?
Şu mantık ile yapsanız; a1 ile a5 hücreleri arasındaki sayıları kontrol edelim.

A1:4
A2:4
A3:4
A4:4
A5:4

5 hücrenin toplamı alınır ve 5'e bölünür. Çıkan Sonuç A1 hücresine eşit ise sütun silinir, eğer çıkan sonuç A1 hücresinden büyük veya küçük ise işlem yapılmaz.

Hücrelerden herhangi birinin bile farklı olması sonucunda sütunun silinmeyeceği koşuluna göre bu mantık ile işlem yapılabilir. Eğer 5'e bölündüğünde çıkan ortalama herhangi birine eşit değilse işlem yapılmaz.


Çok teşekkürler yorumunuz için fakat bütün hücreleri kapsayacak şekilde bir şey isteniyor


Miraç CAN yazdı:Deneyin:
Kod: Tümünü seç
Sub DeleteColumns()
Dim FrstCl&, ScndCl&, FrstEndRw&
Dim EndClmn&, Rw&, Eql As Boolean
EndClmn = [A1].End(2).Column
Do
    FrstCl = FrstCl + 1: ScndCl = FrstCl
    FrstEndRw = Cells(Rows.Count, FrstCl).End(3).Row
    Do
        ScndCl = ScndCl + 1
        If FrstEndRw = Cells(Rows.Count, ScndCl).End(3).Row Then
            For Rw = 1 To FrstEndRw
                If Not Cells(Rw, FrstCl) Like Cells(Rw, ScndCl) Then Eql = True: Exit For
            Next Rw
            If Not Eql Then Columns(ScndCl).Delete: EndClmn = EndClmn - 1: ScndCl = ScndCl - 1
            Eql = False
        End If
    Loop While ScndCl < EndClmn
Loop While FrstCl < EndClmn - 1
End Sub


Size de çok teşekkür ederim denedim fakat çalıştıramadım sanırım.
Benim bugüne kadar excel le alakalı bir geçmişim falan yok böyle bir proje verildiği için zorlandım ve tam olarak ne yapacağımı bilmiyorum makrolar kısmından module içine yapıştırıp çalıştırmaya çalışıyorum üstteki kodları ama çalıştıramadım.

Kod: Tümünü seç
Sub df()
Dim i As Integer

For a = [a65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("a1:a" & a), Cells(a, "a")) > 1 Then Columns("a:a").Delete
Next

End Sub


bende şöyle bir kod var fakat >1 ibaresi yüzünden 1 den fazla aynı olan değerleri siliyor yani bir sütunda 1-1-2 var diyelim bir taneden fazla 1 olduğu için o sütunu yine de siliyor.
Bunun yerine sütundaki dolu hücre sayısını sayıp = ifadesiyle yazabilsem sorun çözülecek gibi geliyor.Tabi yine de tam anlamadığım için kodları bu sadece tahmin daha iyisini bilen birisi yardımcı olabilirse çok mutlu olacağım

Tekrardan teşekkürler yorumlarınız için.
Kullanıcı avatarı
Elvish
Yeni Başlamış
 
Kayıt: 26 Ekm 2020 12:09
Meslek: Öğrenci
Yaş: 27
İleti: 10
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: Aynı değerlere sahip sütunu silme

İleti#7)  veyselemre » 27 Ekm 2020 18:19

Kod: Tümünü seç
Sub sutundaFarkliDegerVarsaSutunuSil()
    Dim alan As Range
    Dim colAlan As Range
    Dim i As Long
    Dim ii As Long
    Dim iii As Long
    Dim ilkDeger As String
    Dim farkliDegerYok As Boolean

    Set alan = ActiveSheet.UsedRange
    If alan Is Nothing Then Exit Sub

    For i = alan.Columns.Count To 1 Step -1
        ilkDeger = ""
        Set colAlan = alan.Columns(i)
        colAlan.Select
        If WorksheetFunction.CountA(colAlan) > 0 Then

            For ii = 1 To colAlan.Rows.Count
                If colAlan.Cells(1).Value <> "" And ilkDeger = "" Then
                    ilkDeger = colAlan.Cells(ii).Value
                    Exit For
                End If
            Next ii
           
            farkliDegerYok = True
            For iii = ii + 1 To colAlan.Rows.Count
                If colAlan.Cells(iii).Value <> "" And colAlan.Cells(iii).Value <> ilkDeger Then
                    farkliDegerYok = False
                    Exit For
                End If
            Next iii
           
            If farkliDegerYok Then colAlan.EntireColumn.Delete
       
        End If
       
    Next i

End Sub
Kullanıcı avatarı
veyselemre
Siteye Alışmış
 
Kayıt: 28 Nis 2015 15:53
Meslek: SERBEST
Yaş: 105
İleti: 428
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çubuk

Cevap: Cevap: Aynı değerlere sahip sütunu silme

İleti#8)  Elvish » 27 Ekm 2020 18:39

veyselemre yazdı:
Kod: Tümünü seç
Sub sutundaFarkliDegerVarsaSutunuSil()
    Dim alan As Range
    Dim colAlan As Range
    Dim i As Long
    Dim ii As Long
    Dim iii As Long
    Dim ilkDeger As String
    Dim farkliDegerYok As Boolean

    Set alan = ActiveSheet.UsedRange
    If alan Is Nothing Then Exit Sub

    For i = alan.Columns.Count To 1 Step -1
        ilkDeger = ""
        Set colAlan = alan.Columns(i)
        colAlan.Select
        If WorksheetFunction.CountA(colAlan) > 0 Then

            For ii = 1 To colAlan.Rows.Count
                If colAlan.Cells(1).Value <> "" And ilkDeger = "" Then
                    ilkDeger = colAlan.Cells(ii).Value
                    Exit For
                End If
            Next ii
           
            farkliDegerYok = True
            For iii = ii + 1 To colAlan.Rows.Count
                If colAlan.Cells(iii).Value <> "" And colAlan.Cells(iii).Value <> ilkDeger Then
                    farkliDegerYok = False
                    Exit For
                End If
            Next iii
           
            If farkliDegerYok Then colAlan.EntireColumn.Delete
       
        End If
       
    Next i

End Sub



çok teşekkür ederim bu tam istediğim şey.Peki bunu hem satır hem sütun olarak aynı anda tarama yaptırıp, hepsi aynı olan kısmı sildirmek istesem nasıl yaparım?(biliyorum çok soru sordum fakat sonradan hoca ekleme yaptı uğraştırdığım için özür dilerim)
Kullanıcı avatarı
Elvish
Yeni Başlamış
 
Kayıt: 26 Ekm 2020 12:09
Meslek: Öğrenci
Yaş: 27
İleti: 10
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir

Cevap: Aynı değerlere sahip sütunu silme

İleti#9)  veyselemre » 28 Ekm 2020 08:40

Sorunuz net değil aynı anda tarama yaptırmak ne demek, sırasıyla hücreler seçilip o hücreye ait satır ve sütün mu taranacak.
Bir satır veya sütün silindikten sonra yeni halinde sadece benzersiz veriler kalabilir sütun veya satırda,
Sorunuzla ilgili detaylı bir örnek üzerinde silinmesi gerekenleri gösterin.
Kullanıcı avatarı
veyselemre
Siteye Alışmış
 
Kayıt: 28 Nis 2015 15:53
Meslek: SERBEST
Yaş: 105
İleti: 428
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çubuk

Cevap: Cevap: Aynı değerlere sahip sütunu silme

İleti#10)  Miraç CAN » 28 Ekm 2020 09:28

Elvish yazdı:
Miraç CAN yazdı:Deneyin:
Kod: Tümünü seç
Sub DeleteColumns()
Dim FrstCl&, ScndCl&, FrstEndRw&
Dim EndClmn&, Rw&, Eql As Boolean
EndClmn = [A1].End(2).Column
Do
    FrstCl = FrstCl + 1: ScndCl = FrstCl
    FrstEndRw = Cells(Rows.Count, FrstCl).End(3).Row
    Do
        ScndCl = ScndCl + 1
        If FrstEndRw = Cells(Rows.Count, ScndCl).End(3).Row Then
            For Rw = 1 To FrstEndRw
                If Not Cells(Rw, FrstCl) Like Cells(Rw, ScndCl) Then Eql = True: Exit For
            Next Rw
            If Not Eql Then Columns(ScndCl).Delete: EndClmn = EndClmn - 1: ScndCl = ScndCl - 1
            Eql = False
        End If
    Loop While ScndCl < EndClmn
Loop While FrstCl < EndClmn - 1
End Sub


Size de çok teşekkür ederim denedim fakat çalıştıramadım sanırım.
Benim bugüne kadar excel le alakalı bir geçmişim falan yok böyle bir proje verildiği için zorlandım ve tam olarak ne yapacağımı bilmiyorum makrolar kısmından module içine yapıştırıp çalıştırmaya çalışıyorum üstteki kodları ama çalıştıramadım.

İlgili verilerinizin A1 hücresinden başlayıp yer aldığını varsayarak oluşturuldu bu örnek yordam.
Veri dosyası eklemediğiniz için kullanabileceğiniz bir örnek arıyorsunuz sandım, tam ihtiyaca yönelik bir çalışma verdiğiniz bilgiler ışığında pek mümkün değildi.
Bu şekilde kullanabilirsiniz:
Kod: Tümünü seç
Sub DeleteColumns()
Dim FrstCl&, FrstRw&, ScndCl&, FrstEndRw&
Dim EndCl&, Rw&, Eql As Boolean
EndCl = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
FrstCl = ActiveSheet.UsedRange.Columns(1).Column
FrstRw = ActiveSheet.UsedRange.Rows(1).Row
Do
    ScndCl = FrstCl
    FrstEndRw = Cells(Rows.Count, FrstCl).End(3).Row
    Do
        ScndCl = ScndCl + 1
        If FrstEndRw = Cells(Rows.Count, ScndCl).End(3).Row Then
            For Rw = FrstRw To FrstEndRw
                If Not Cells(Rw, FrstCl) Like Cells(Rw, ScndCl) Then Eql = True: Exit For
            Next Rw
            If Not Eql Then Columns(ScndCl).Delete: EndCl = EndCl - 1: ScndCl = ScndCl - 1
            Eql = False
        End If
    Loop While ScndCl < EndCl
    FrstCl = FrstCl + 1
Loop While FrstCl < EndCl
End Sub

Elvish yazdı:Peki bunu hem satır hem sütun olarak aynı anda tarama yaptırıp, hepsi aynı olan kısmı sildirmek istesem nasıl yaparım?(biliyorum çok soru sordum fakat sonradan hoca ekleme yaptı uğraştırdığım için özür dilerim)

Çok soru sormuyorsunuz aslında, eksik ve yetersiz bilgilerle çözüm aramaya çalışıyorsunuz.
Kaldı ki burası bir Forum, bu gibi amaçlar için oluşturulmuş bir sanal ortam.
Söylediğiniz yapılabilir fakat yapmak istediğiniz tam anlaşılmadığı için işin sonu "yandı gülüm keten helva" olmasın. Bölük pörçük, taksit taksit; şöyleydi, şu da vardı, bu olmayacaktı... vs.. uzayıp gitmesin konu.
Kısa, net, öz olsun; kolayca çözülsün/anlaşılsın.
Benim anladığım, aynı verilere sahip satır ve sütunlar kaldırılsın istiyorsunuz. Yoksa benzer içerikli hücreler mi kastınız, ya da ne..?
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 803
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

Cevap: Aynı değerlere sahip sütunu silme

İleti#11)  Elvish » 28 Ekm 2020 11:06

Miraç CAN yazdı:Çok soru sormuyorsunuz aslında, eksik ve yetersiz bilgilerle çözüm aramaya çalışıyorsunuz.
Kaldı ki burası bir Forum, bu gibi amaçlar için oluşturulmuş bir sanal ortam.
Söylediğiniz yapılabilir fakat yapmak istediğiniz tam anlaşılmadığı için işin sonu "yandı gülüm keten helva" olmasın. Bölük pörçük, taksit taksit; şöyleydi, şu da vardı, bu olmayacaktı... vs.. uzayıp gitmesin konu.
Kısa, net, öz olsun; kolayca çözülsün/anlaşılsın.
Benim anladığım, aynı verilere sahip satır ve sütunlar kaldırılsın istiyorsunuz. Yoksa benzer içerikli hücreler mi kastınız, ya da ne..?


Evet "Benim anladığım, aynı verilere sahip satır ve sütunlar kaldırılsın istiyorsunuz. " tam olarak anlatmak istediğim şey bu söylediğiniz.
Resimli olarak şöyle göstereyim;


Resim

Burada kırmızıyla işaretlenmiş değerler aynı olduğu için silinmesi gerekiyor.
Kullanıcı avatarı
Elvish
Yeni Başlamış
 
Kayıt: 26 Ekm 2020 12:09
Meslek: Öğrenci
Yaş: 27
İleti: 10
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir

Cevap: Aynı değerlere sahip sütunu silme

İleti#12)  Miraç CAN » 28 Ekm 2020 11:21

Doğru mu anlıyorum, A ve C sütunları, 5 ve 6. satırlar silinsin istiyorsunuz?
Benim ilk anladığım, açıklama resmine göre; C sütunu, 5 ve 6. satır silinsin gibiydi.
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 803
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

Cevap: Aynı değerlere sahip sütunu silme

İleti#13)  veyselemre » 28 Ekm 2020 11:37

Kod: Tümünü seç
Sub sutunSatirHepAyniDegerVarsaSil()
    Dim alan As Range
    Dim colAlan As Range, rowAlan As Range
    Dim silineceklerSutunlar As Range
    Dim silineceklerSatirlar As Range
    Dim i As Long
    Dim ii As Long
    Dim ilkDeger As String
    Dim farkliDegerVar As Boolean

    Set alan = ActiveSheet.UsedRange
    If alan Is Nothing Then Exit Sub

    For i = alan.Columns.Count To 1 Step -1
        ilkDeger = ""
        Set colAlan = alan.Columns(i)
        If WorksheetFunction.CountA(colAlan) > 0 Then
            farkliDegerVar = False
            For ii = 1 To colAlan.Rows.Count
                If colAlan.Cells(ii).Value <> "" Then
                    If ilkDeger = "" Then
                        ilkDeger = colAlan.Cells(ii).Value
                    Else
                        If colAlan.Cells(ii).Value <> ilkDeger Then
                            farkliDegerVar = True
                            Exit For
                        End If
                    End If
                End If
            Next ii
            If Not farkliDegerVar Then
                If silineceklerSutunlar Is Nothing Then
                    Set silineceklerSutunlar = colAlan.EntireColumn
                Else
                    Set silineceklerSutunlar = Union(silineceklerSutunlar, colAlan.EntireColumn)
                End If
            End If
        End If
    Next i

    Set alan = ActiveSheet.UsedRange
    If alan Is Nothing Then Exit Sub

    For i = alan.Rows.Count To 1 Step -1
        ilkDeger = ""
        Set rowAlan = alan.Rows(i)
        If WorksheetFunction.CountA(rowAlan) > 0 Then
            rowAlan.Select

            farkliDegerVar = False
            For ii = 1 To rowAlan.Columns.Count
                If rowAlan.Cells(ii).Value <> "" Then
                    If ilkDeger = "" Then
                        ilkDeger = rowAlan.Cells(ii).Value
                    Else
                        If rowAlan.Cells(ii).Value <> ilkDeger Then
                            farkliDegerVar = True
                            Exit For
                        End If
                    End If
                End If
            Next ii
            If Not farkliDegerVar Then
                If silineceklerSatirlar Is Nothing Then
                    Set silineceklerSatirlar = rowAlan.EntireRow
                Else
                    Set silineceklerSatirlar = Union(silineceklerSatirlar, rowAlan.EntireRow)
                End If
            End If

        End If
    Next i
   
    If Not silineceklerSutunlar Is Nothing Then silineceklerSutunlar.Delete
    If Not silineceklerSatirlar Is Nothing Then silineceklerSatirlar.Delete

End Sub
Kullanıcı avatarı
veyselemre
Siteye Alışmış
 
Kayıt: 28 Nis 2015 15:53
Meslek: SERBEST
Yaş: 105
İleti: 428
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çubuk

Cevap: Aynı değerlere sahip sütunu silme

İleti#14)  Elvish » 28 Ekm 2020 12:29

veyselemre yazdı:
Kod: Tümünü seç
Sub sutunSatirHepAyniDegerVarsaSil()
    Dim alan As Range
    Dim colAlan As Range, rowAlan As Range
    Dim silineceklerSutunlar As Range
    Dim silineceklerSatirlar As Range
    Dim i As Long
    Dim ii As Long
    Dim ilkDeger As String
    Dim farkliDegerVar As Boolean

    Set alan = ActiveSheet.UsedRange
    If alan Is Nothing Then Exit Sub

    For i = alan.Columns.Count To 1 Step -1
        ilkDeger = ""
        Set colAlan = alan.Columns(i)
        If WorksheetFunction.CountA(colAlan) > 0 Then
            farkliDegerVar = False
            For ii = 1 To colAlan.Rows.Count
                If colAlan.Cells(ii).Value <> "" Then
                    If ilkDeger = "" Then
                        ilkDeger = colAlan.Cells(ii).Value
                    Else
                        If colAlan.Cells(ii).Value <> ilkDeger Then
                            farkliDegerVar = True
                            Exit For
                        End If
                    End If
                End If
            Next ii
            If Not farkliDegerVar Then
                If silineceklerSutunlar Is Nothing Then
                    Set silineceklerSutunlar = colAlan.EntireColumn
                Else
                    Set silineceklerSutunlar = Union(silineceklerSutunlar, colAlan.EntireColumn)
                End If
            End If
        End If
    Next i

    Set alan = ActiveSheet.UsedRange
    If alan Is Nothing Then Exit Sub

    For i = alan.Rows.Count To 1 Step -1
        ilkDeger = ""
        Set rowAlan = alan.Rows(i)
        If WorksheetFunction.CountA(rowAlan) > 0 Then
            rowAlan.Select

            farkliDegerVar = False
            For ii = 1 To rowAlan.Columns.Count
                If rowAlan.Cells(ii).Value <> "" Then
                    If ilkDeger = "" Then
                        ilkDeger = rowAlan.Cells(ii).Value
                    Else
                        If rowAlan.Cells(ii).Value <> ilkDeger Then
                            farkliDegerVar = True
                            Exit For
                        End If
                    End If
                End If
            Next ii
            If Not farkliDegerVar Then
                If silineceklerSatirlar Is Nothing Then
                    Set silineceklerSatirlar = rowAlan.EntireRow
                Else
                    Set silineceklerSatirlar = Union(silineceklerSatirlar, rowAlan.EntireRow)
                End If
            End If

        End If
    Next i
   
    If Not silineceklerSutunlar Is Nothing Then silineceklerSutunlar.Delete
    If Not silineceklerSatirlar Is Nothing Then silineceklerSatirlar.Delete

End Sub


Çok çok çok teşekkür ederim istediğim şey buydu ellerinize, emeğinize sağlık.

Diğer yorum yapıp ilgilenen herkese de teşekkürler.
Kullanıcı avatarı
Elvish
Yeni Başlamış
 
Kayıt: 26 Ekm 2020 12:09
Meslek: Öğrenci
Yaş: 27
İleti: 10
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir

Cevap: Aynı değerlere sahip sütunu silme

İleti#15)  Miraç CAN » 28 Ekm 2020 13:51

veyselemre Bey'e hazırlamış olduğu kodlar için teşekkürler,
Ben de hazırlamış olduğum yordamı revize etmiştim, farklı bir örnek olarak bulunsun:
Kod: Tümünü seç
Sub EqualRowsColumnsDelete()
Dim FrstCl&, FrstRw&, Cl&, RwDlt&, Calc&
Dim EndCl&, EndRw&, Rw&, Eql As Boolean, Clmn() As Boolean
Calc = Application.Calculation: Application.Calculation = xlCalculationManual
With ActiveSheet.UsedRange
    FrstCl = .Columns(1).Column
    FrstRw = .Rows(1).Row
    EndCl = .Columns(.Columns.Count).Column
    EndRw = .Rows(.Rows.Count).Row
End With
ReDim Clmn(FrstCl To EndCl) As Boolean
Do
    Cl = FrstCl
    Do
        Cl = Cl + 1
        Rw = FrstRw
        Do
            RwDlt = Application.CountIf(Range(Cells(Rw, FrstCl), Cells(Rw, EndCl)), Cells(Rw, FrstCl))
            If RwDlt = ActiveSheet.UsedRange.Columns.Count Then
                Rows(Rw).Delete: EndRw = EndRw - 1: Rw = Rw - 1
            Else
                If Not Cells(Rw, FrstCl) Like Cells(Rw, Cl) Then Eql = True
            End If
            Rw = Rw + 1
        Loop While Rw <= EndRw
        If Not Eql Then Clmn(FrstCl) = True: Clmn(Cl) = True
        Eql = False
    Loop While Cl < EndCl
    FrstCl = FrstCl + 1
Loop While FrstCl < EndCl
For Cl = UBound(Clmn) To LBound(Clmn) Step -1
    If Clmn(Cl) Then Columns(Cl).Delete
Next Cl
Application.Calculation = Calc
End Sub
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 803
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

Cevap: Cevap: Aynı değerlere sahip sütunu silme

İleti#16)  okutkan » 28 Ekm 2020 13:55

Miraç CAN yazdı:veyselemre Bey'e hazırlamış olduğu kodlar için teşekkürler,
Ben de hazırlamış olduğum yordamı revize etmiştim, farklı bir örnek olarak bulunsun:
Kod: Tümünü seç
Sub EqualRowsColumnsDelete()
Dim FrstCl&, FrstRw&, Cl&, RwDlt&, Calc&
Dim EndCl&, EndRw&, Rw&, Eql As Boolean, Clmn() As Boolean
Calc = Application.Calculation: Application.Calculation = xlCalculationManual
With ActiveSheet.UsedRange
    FrstCl = .Columns(1).Column
    FrstRw = .Rows(1).Row
    EndCl = .Columns(.Columns.Count).Column
    EndRw = .Rows(.Rows.Count).Row
End With
ReDim Clmn(FrstCl To EndCl) As Boolean
Do
    Cl = FrstCl
    Do
        Cl = Cl + 1
        Rw = FrstRw
        Do
            RwDlt = Application.CountIf(Range(Cells(Rw, FrstCl), Cells(Rw, EndCl)), Cells(Rw, FrstCl))
            If RwDlt = ActiveSheet.UsedRange.Columns.Count Then
                Rows(Rw).Delete: EndRw = EndRw - 1: Rw = Rw - 1
            Else
                If Not Cells(Rw, FrstCl) Like Cells(Rw, Cl) Then Eql = True
            End If
            Rw = Rw + 1
        Loop While Rw <= EndRw
        If Not Eql Then Clmn(FrstCl) = True: Clmn(Cl) = True
        Eql = False
    Loop While Cl < EndCl
    FrstCl = FrstCl + 1
Loop While FrstCl < EndCl
For Cl = UBound(Clmn) To LBound(Clmn) Step -1
    If Clmn(Cl) Then Columns(Cl).Delete
Next Cl
Application.Calculation = Calc
End Sub



Bana Buradaki kodlar çok karmaşık geldi. Bu bilgileri sıfırdan hobi olarak mı öğrendiniz yoksa okulda mı kendinizi geliştirdiniz?
Kullanıcı avatarı
okutkan
Yeni Başlamış
 
Kayıt: 27 May 2017 02:45
Meslek: pol. mem.
Yaş: 28
İleti: 99
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: DENİZLİ

Cevap: Aynı değerlere sahip sütunu silme

İleti#17)  Miraç CAN » 28 Ekm 2020 14:45

Aslında gayet basit ve yalın, biraz Basic öğrenmiştik okulda ama hobi olarak üzerine ekledim diyelim.
Kullanıcı avatarı
Miraç CAN
Site Dostu
 
Kayıt: 26 Arl 2016 19:07
Meslek: Harita/Ölçme
Yaş: 39
İleti: 803
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Amasya & Adana

Cevap: Aynı değerlere sahip sütunu silme

İleti#18)  Elvish » 28 Ekm 2020 17:43

Miraç CAN yazdı:veyselemre Bey'e hazırlamış olduğu kodlar için teşekkürler,
Ben de hazırlamış olduğum yordamı revize etmiştim, farklı bir örnek olarak bulunsun:
Kod: Tümünü seç
Sub EqualRowsColumnsDelete()
Dim FrstCl&, FrstRw&, Cl&, RwDlt&, Calc&
Dim EndCl&, EndRw&, Rw&, Eql As Boolean, Clmn() As Boolean
Calc = Application.Calculation: Application.Calculation = xlCalculationManual
With ActiveSheet.UsedRange
    FrstCl = .Columns(1).Column
    FrstRw = .Rows(1).Row
    EndCl = .Columns(.Columns.Count).Column
    EndRw = .Rows(.Rows.Count).Row
End With
ReDim Clmn(FrstCl To EndCl) As Boolean
Do
    Cl = FrstCl
    Do
        Cl = Cl + 1
        Rw = FrstRw
        Do
            RwDlt = Application.CountIf(Range(Cells(Rw, FrstCl), Cells(Rw, EndCl)), Cells(Rw, FrstCl))
            If RwDlt = ActiveSheet.UsedRange.Columns.Count Then
                Rows(Rw).Delete: EndRw = EndRw - 1: Rw = Rw - 1
            Else
                If Not Cells(Rw, FrstCl) Like Cells(Rw, Cl) Then Eql = True
            End If
            Rw = Rw + 1
        Loop While Rw <= EndRw
        If Not Eql Then Clmn(FrstCl) = True: Clmn(Cl) = True
        Eql = False
    Loop While Cl < EndCl
    FrstCl = FrstCl + 1
Loop While FrstCl < EndCl
For Cl = UBound(Clmn) To LBound(Clmn) Step -1
    If Clmn(Cl) Then Columns(Cl).Delete
Next Cl
Application.Calculation = Calc
End Sub



Size de çok teşekkür ederim kaydettim bu kodları da emeğinize sağlık.
Kullanıcı avatarı
Elvish
Yeni Başlamış
 
Kayıt: 26 Ekm 2020 12:09
Meslek: Öğrenci
Yaş: 27
İleti: 10
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İzmir


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: Google [Bot] ve 2 misafir

Bumerang - Yazarkafe