Veri Sıralama.

[simetri.]

Merhabalar

Verileri sıralama ile ilgili makro oluşturmak istedim
lakin başarılı olamadım. Yardımcı olabilirseniz sevinirim.
Teşekkür ederim.

 

[Necdet]

Merhabalar

Verileri sıralama ile ilgili makro oluşturmak istedim
lakin başarılı olamadım. Yardımcı olabilirseniz sevinirim.
Teşekkür ederim.

Merhaba,

Sıralama diyorsunuz ama nasıl bir sıralama olduğunu anlamadım.

 

[simetri.]

Necdet hocam merhaba;

Konu başlığı ile içerik tam olarak uyuşmadı evet.
Uygun bir başlıkla değiştirebilirseniz şayet sevinirim.

Örnek dosyada kodun amacını izah ettim, eğer ki anlaşılmayan
br durum var ise içeriği düzelteceğim. Saygılar hocam.

 

[Necdet]

Merhaba,

Hücreleri x lere göre kaydırma yaptırmak istiyorsunuz sanırım.

İlginç bir soru, algoritmayı bulan yapar.

Tabloda satır ve sütun sayısı sabit mi?

 

[Necdet]

Tekrar merhaba,

Varsayılan tablonun dosyada olduğu gibi varsayılmıştır.

D3 hücresinden başlıyor (tablonun sol üst köşesi) varsayılmıştır.

satır ve sütun sayısı ise Current.Region ile bulunmaya çalışılmıştır.
Buna göre D3 hücresinin sağı solu ve yukarısı doluysa yanlış satır ve sütun numaraları oluşabilir.

Gerekirse siz bu satır ve sütun numaralarını dosyanın içine sabitleyebilirsiniz.

Kodları denemeden önce dosyanızın yedeğini almayı unutmayınız.

Sub Duzenle()
 
    Dim i       As Long, _
        j       As Integer, _
        MaxX    As Integer, _
        MaxA    As Integer, _
        MinA    As Integer, _
        Sat     As Long, _
        Kol     As Integer
    
    Application.ScreenUpdating = False
    
    Sat = 2 + Range("D3").CurrentRegion.Rows.Count
    Kol = 3 + Range("D3").CurrentRegion.Columns.Count
    
    For i = 3 To Sat
    
        MaxX = 3
        MaxA = 3
        MinA = Kol + 1
        j = 4
        
        Do
            If Cells(i, j) = "x" Or Cells(i, j) = "X" Then
                If j > MaxX Then MaxX = j
            End If
            
            If Not Cells(i, j) = "x" And Not Cells(i, j) = "X" Then
                If j > MaxA Then MaxA = j
                If j < MinA Then MinA = j
            End If
        j = j + 1
        Loop While j <= Kol
        Range(Cells(i, MinA), Cells(i, MaxA)).Cut
        Range(Cells(i, MinA + (Kol - MaxA)), Cells(i, MaxA + (Kol - MaxA))).Select
        ActiveSheet.Paste
        Range(Cells(i, 4), Cells(i, Kol)).Replace What:="x", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

 

[Murat OSMA]

Dosyadaki açıklamada: "x" ler hayalidir x olan hücreleri silip diğerlerini sağa yanaştırıp blok yapacağız. şeklinde belirtilmesi işi anlamsızlaştırıp güçleştiriyor... :dusun:

 

[Necdet]

Dosyadaki açıklamada: "x" ler hayalidir x olan hücreleri silip diğerlerini sağa yanaştırıp blok yapacağız. şeklinde belirtilmesi işi anlamsızlaştırıp güçleştiriyor... :dusun:

Zaten olayı tam da anlamadım, x varmış gibi yaptım xleri kaldırır boşluk denetimini koyarız

Bakalım soru sahibi ne diyecek

 

[Murat OSMA]

Hayâli işlerle uğraşıyoruz.

Aslında olayı çözdüm ama dediğiniz gibi bakalım çözüm için ne yanıt gelecek ?

 

[simetri.]

Merhabalar Necdet Hocam.

Kodun içinde "x" lerin olmaması gerekiyor.
Tekrardan örnek dosya hazırladım. Açıklamayı
detaylandırdım. Bakabilirseniz şayet çok sevinirim.

 

[Necdet]

Merhaba,

Ben aynı mantıkla bu seferde X'siz olarak düşündüm. Aşağıdaki kodları deneyiniz.

Satır ve Sütun bitişlerini belirtiniz.

Sub Duzenle()
    
    Dim i       As Long, _
        j       As Integer, _
        MaxA    As Integer, _
        MinA    As Integer, _
        Sat     As Long, _
        Kol     As Integer
    
    Application.ScreenUpdating = False
    
    Sat = 6
    Kol = 10
    
    For i = 3 To Sat
    
        MaxA = 3
        MinA = Kol + 1
        j = Kol
        
        Do
            
            If Not Cells(i, j) = "" Then
                If j > MaxA Then MaxA = j
                If j < MinA Then MinA = j
            End If
        j = j - 1
        Loop Until j < 4
        
        Range(Cells(i, MinA), Cells(i, MaxA)).Cut
        Range(Cells(i, MinA + (Kol - MaxA)), Cells(i, MaxA + (Kol - MaxA))).Select
        ActiveSheet.Paste
        
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

 

[simetri.]

Merhabalar değerli hocam.

Emeğiniz için çok çok teşekkür ederim. Satır ve sütun bitişleri sabit olduğu
zaman makrodan tam manası ile verim alamayız hocam.

Örnek dosyada da belirttiğim gibi tanımlı bir alanda (A1:AA111 gibi) son dolu hücrenin
sütununu kılavuz olarak kullanarak kodu kurgular isek kod çok daha işlevsel olur.
Bu imkanımız var ise tabii. Saygılar hocam.

 

[Murat OSMA]

Sn. simetri, daha önce de bunu size birkaç kez ifade etmiştim ama sanırım dikkate alınmıyoruz.
Yapmak istediğiniz her ne ise onun son hâlini bizlere verin ki, kodları tekrar tekrar yazmak zorunda kalmayalım.
Bir örnek hazırlıyorsunuz ve sizin ihtiyacınızı karşılayan bir çözüm sunuluyor, bizim açımızdan konu çözümlenmiş oluyor ama konu sizin tarafınızda askıda kalıyor.
Çünkü yapmak istediğinizi tam olarak net bir biçimde bizlere aktarmıyorsunuz. Matruşka bebekleri gibi çözdükçe içinden başka sorular, sorunlar çıkıyor.
Sorununuza böyle bir çözüm bulamazsınız ve bu bizleri uğraştırmaktan başa bir işe yaramaz.

Meselâ ilk verdiğiniz örnekteki hücre aralığı ile sonradan gönderdiğiniz dosyanın hücre aralığının aynı olmayışı yetmiyor gibi son mesajınızdaki hücre aralığı da ap ayrı. Hangisine göre çözüm hazırlayacağız ?

Sizin yanlış aktaracağınız tek bir hücre, tek bir karakter bile kodların yeniden yazılmasına sebep olabilir. Ama siz bunu idrak edebilecek kapasitede biri olmanıza rağmen, size yardım etmek için uğraşan kişilerin harcayacağı emeği, vakti düşünmüyorsunuz.



İlk dosyanıza göre aşağıdaki kodları hazırlamıştım ama size göndermedim.
Çünkü; adım gibi emindim ki cevap verince konu bitmeyecekti ki öyle de oldu.
Sonra dosya değişti, kodları uygulayacağınız alan değişti. Böyle olursa vaktimi çaldığınızı düşünüyorum ve size bir yanıt vermek içimden gelmiyor. Sadece benim değil tabii ki, herkes için bu böyle..

Sub Sütun_Ekle()
    Dim i As Integer, a As Integer, say As Integer
    On Error Resume Next
     For i = 6 To 3 Step -1
        For a = 10 To 4 Step -1
            If Cells(i, "J") = "" And Cells(i, a) = "" Then
                say = say + 1
                Cells(i, 5 - say).Insert Shift:=xlToRight
            End If
        Next a
         say = Empty
    Next i
    i = Empty: a = Empty: say = Empty
End Sub

Lütfen bu konuda daha hassas olmanızı rica ediyorum.


Hoşça kalın !

 

[Necdet]

Merhabalar değerli hocam.

Emeğiniz için çok çok teşekkür ederim. Satır ve sütun bitişleri sabit olduğu
zaman makrodan tam manası ile verim alamayız hocam.

Örnek dosyada da belirttiğim gibi tanımlı bir alanda (A1:AA111 gibi) son dolu hücrenin
sütununu kılavuz olarak kullanarak kodu kurgular isek kod çok daha işlevsel olur.
Bu imkanımız var ise tabii. Saygılar hocam.

Bu tür açıklamaları ilk mesajda vermeliydiniz. Murat bey doğru yere parmak basmış.

Ben de 2 ayrı kod yazmak zorunda kaldım. Oysa değişken bir tablo deseydiniz onun seçimini size bırakır kodları ona göre yazardık.

Şimdi kendi işlerimi halletmem gerek, sonra fırsat bulursam üzerinde düşünebilirim.

Ya da siz kodları revize edebilirseniz kendinize uyarlayınız.

 

[simetri.]

Son dolu hücreyi tespit ederek satırları sağdan blok yapma.

Merhabalar.

Tanımlanan alandaki son dolu hücreyi tespit edip.
İlgili sütunu kılavuz olarak kullanmak sureti ile
Diğer satırları sağdan blok yapmaya çalışacağız.

Değerli yardımlarınızı bekliyorum.

 

[simetri.]

...........

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[Necdet]

Merhaba,

Aşağıdaki kodları çalıştırmadan önce Çalışacağınız alanı seçtikten sonra çalıştırınız.

Bu konu ile önceki konuyu da birleştirmek gerek.

Sub Duzenle()
    
    Dim BasRow  As Long, _
        SonRow  As Long, _
        BasCol  As Integer, _
        SonCol  As Integer, _
        i       As Long, _
        j       As Integer, _
        k       As Integer
        
    If Selection.Count = 1 Then Exit Sub
    
    BasRow = Selection.Row
    BasCol = Selection.Column
    
    SonRow = Selection.Rows.Count + BasRow - 1
    SonCol = Selection.Columns.Count + BasCol - 1
    
    Application.ScreenUpdating = False
    
    For i = BasRow To SonRow
        j = Cells(i, SonCol + 1).End(1).Column
        If j > 1 Then
            k = BasCol + (SonCol - j)
            Range(Cells(i, BasCol), Cells(i, j)).Cut Range(Cells(i, k), Cells(i, k))
        End If
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem Tamamlanmıştır....", vbInformation, "Necdet YEŞERTENER, 4 Aralık 2013 Ankara - excel.web.tr"
    
End Sub

 

[simetri.]

Sayın Necdet hocam. Çok çok teşekkür ederim.

Kodumuz bu hali ile vazifesini yapıyor. Ellerinize sağlık.
C2:O15 aralığında ki son dolu hücreyi tesbit edip; Başlangıç hücresi (C2:son dolu)
seçecek başka bir kod yazılır ise mevcut makro ile sıralı şekilde kullanılabilir.
Eğer mümkünatı var ise daha şık olur. Tekrardan teşekkür eder saygılar sunarım.

 

[simetri.]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Sayın muygun üstad.
Konuya gösterdiğiniz ilgi ve alaka için teşekkür ederim.

Tasarladığınız kod çalışıyor. Lakin sonuçları V2:AI15 de değilde
C215 de göstermesi gerek. Kullandığınız yardımcı sütun olan "q"
sütununu da "DD" sütunu gibi gözden ırak bir sütuna uygular isek
sizin kodu da denemek isterim. Çok teşekkür ederim emeğiniz için.

 

[Necdet]

Sayın Necdet hocam. Çok çok teşekkür ederim.

Kodumuz bu hali ile vazifesini yapıyor. Ellerinize sağlık.
C2:O15 aralığında ki son dolu hücreyi tesbit edip; Başlangıç hücresi (C2:son dolu)
seçecek başka bir kod yazılır ise mevcut makro ile sıralı şekilde kullanılabilir.
Eğer mümkünatı var ise daha şık olur. Tekrardan teşekkür eder saygılar sunarım.

Ben kodlarda zaten başlangıç ve son dolu hücreyi seçmenizi istiyorum.

C2:O15 olarak seçeceğinize, D3:N13 seçtiğiniz an işinizi zaten görüyor. Sadece seçimle isteğiniz olacaktır.

Daha fazla aralık seçerek, bu aralıktaki ilk hücre ve son hücreyi bulmak kodlara fazladan kod eklemek demektir.