• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

blokları hizalama

Ş

şehiriçi

Katılım
1 Ağustos 2013
Mesajlar
563
Excel Vers. ve Dili
Ofis 2016 TR 32 Bit
Merhaba Arkadaşlar,
Ekteki dosyamda , sütunlarda 60 tane blok var. bu blokları 2 satırdaki Hat1*...Hat2*...Hat3*... le başlayan hat isimlerini A sütunundan itibaren , tüm blokları önce Hat1*...le başlayanlerı sonra numara sırasına göre Hat2*...diye başlayanları Makro ile sıralamak istiyorum .
Desteğiniz ve emeğinizi bekliyorum, saygılarımla ...
 

Ekli dosyalar

Merhaba,
Ben tüm sütunları kendi içinde sıralama olarak anladım.
Doğru anladıysam aşağıdaki kodları kullanabilirsiniz.

Kod: 
Public Sub Dene()

Dim icol As Integer, _
    i As Integer, _
    j As Integer

Application.ScreenUpdating = False

For i = 1 To Cells(1, Columns.Count).End(1).Column
    j = Cells(Rows.Count, i).End(3).Row
    Range(Cells(3, i), Cells(j, i)).Sort key1:=Cells(1, i)
Next i

Application.ScreenUpdating = True

MsgBox "Bitti...."

End Sub
 
Merhaba,
Kusura bakmayın anlamadım. Sorun her sütunun sıralanması değil mi?
 
Necdet bey ,her sütun olduğu gibi kalacak yani her sütun kendi içinde sıralama yok .
Sadece sütunlar daki blokları 2.satırda Hat1*... yazan bloklar önce daha sonra Hat2*...yazanlar ...ve böyle Hat17* yazana kadar devam edecek .
Mesela Hat1*... şeklinde 11 tane sütun , Hat2*...şeklinde 8 tane sütun ....diye devam ediyor.
Mesala Hat1*... le başlayan sütunların kendi arasındaki sıralama önemli değil örnek siralanmış hali sayfasında A sütunu ile B sütunu yer değiştirmiş olması önemli değil ama A sütunu ile L sütunu yer değiştirise olmaz çünkü A sütunu 2. satır Hat1*...le başlıyor L sütunu Hat2*...ile başlıyor .
Kusura bakmayın çok uzattıysam .ne istediğimi anlatmak ta zorlandım
 
Merhaba,
Hat adlarını düzenlediğiniz takdirde sanırım aşağıdaki kodlar işinizi görecektir.
Hat1 ile Hat11 den sonra Hat2 geliyor, ki bu da doğal çünkü text olduğu için.
Hat01, Hat02, Hat11 gibi düzenlerseniz sanırım sıralama düzgün gerçekleşecektir.

Düzenlenmiş halini yine aynı sayfada A24 ten sonra yazdırdım, kontrol edebilmek için, kontrol edip doğru çalıştığını anladığınızda A2 den itibaren listeleyebilirsiniz.

Kod: 
Public Sub deneme()

Dim arV As Variant
Dim arD As Variant

arV = Sayfa1.Range("A2:BH22").Value

arD = Application.WorksheetFunction.Transpose(arV)

arD = BubbleSort(arD, 1, 1)
Sayfa1.Range("A24").Resize(UBound(arV, 1), UBound(arV, 2)) = _
        Application.WorksheetFunction.Transpose(arD)

End Sub

Kod: 
Public Function BubbleSort(arr As Variant, _
                           Optional baslikVar As Integer = 0, _
                           Optional sutunNo As Integer = 1) As Variant
  
    Dim strTemp   As Variant
    Dim i         As Long
    Dim j         As Long
    Dim k         As Integer
    Dim lngMin    As Long
    Dim lngMax    As Long
    
    lngMin = LBound(arr)
    lngMax = UBound(arr)

    ReDim strTemp(LBound(arr, 2) To UBound(arr, 2))
  
    For i = lngMin + baslikVar To lngMax - 1
        For j = i + 1 To lngMax
            If arr(i, sutunNo) > arr(j, sutunNo) Then
                For k = LBound(arr, 2) To UBound(arr, 2)
                    strTemp(k) = arr(i, k)
                Next k
                For k = LBound(arr, 2) To UBound(arr, 2)
                    arr(i, k) = arr(j, k)
                Next k
                For k = LBound(arr, 2) To UBound(arr, 2)
                    arr(j, k) = strTemp(k)
                Next k
              
            End If
        Next j
    Next i
  
    BubbleSort = arr

End Function
 
Necdet Bey , kodu denedim ama çalışmadı ,verdiğiniz kodla beraber dosyayı yüklüyorum .birde siz bakabilir misiniz?
 

Ekli dosyalar

çalışmadı derken?
ben d enedim çalışıyor.
 
Hocanm özür , bazen böyle basit hatalar yapıyorum , doğru siz 24 .satırdan itibaren cevabı yazdırmışsınız .Butona basınca 24 satır görünmeyince neyse... çok teşekkürler dediğiniz gibi olmuş numaralama ,isterdimki 1,2,3...diye gitsin önce ben sizin emek vererek yazdığınız kodu anlamaya çalışacağım. çünki BubbleSort gibi, dizmi mi ...ne bilmediğim bu şeyi öğrenmeye çalışacağım öğrenebilirsem belki 01,02,03....diye yazmak zorunda kalmam çünki gerçek dosyamda 01,02... diye çevirirsem bir çok kod değişecek gibi duruyor ,galiba fazla uzattım hocam çok teşekkürler .
 
Merhaba,
dizi sıralamasını bir kenara bırakın.
alfabetik değerlerin sıralanması hangi yöntemi uygularsanız uygulayın anlamsız sıralama olacaktır.
A1, A2,A10 gibi verileri sıralarsanız A10 A2 den önce gelir.
o yüzden siz hat1 yerine hat01, hat02, hat10 gibi düzenleme yaparsanız düzgün sıralama yapacaktır.
Fakat siz yapamam diyorsunuz ki artık size kalmış ben bir şey diyemem.

Deneme babından hatları siz bir sütuna kopyalayıp denerseniz yanlış sıralama olduğunu görürsünüz, bu da text olmasından kaynaklanıyor.
 
Merhaba,
Takla atarak Blokları Düzgün Sıralamasını Yaptım.
Deneyiniz.
Kod: 
Public Sub BlokSirala()

Dim arV As Variant
Dim arD As Variant

arV = Sayfa1.Range("A1").CurrentRegion.Offset(1).Value
arD = Application.WorksheetFunction.Transpose(arV)

arD = DiziSIRALA(arD, 1, 1)
Sayfa1.Range("A24").Resize(UBound(arV, 1), UBound(arV, 2)) = _
        Application.WorksheetFunction.Transpose(arD)

End Sub

Kod: 
Public Function DiziSIRALA(arr As Variant, _
                           Optional baslikVar As Integer = 0, _
                           Optional sutunNo As Integer = 1) As Variant

    Dim strTemp   As Variant
    Dim i         As Long
    Dim j         As Long
    Dim k         As Integer
    Dim lngMin    As Long
    Dim lngMax    As Long
    Dim hat1      As Variant
    Dim hat2      As Variant
   
    lngMin = LBound(arr)
    lngMax = UBound(arr)

    ReDim strTemp(LBound(arr, 2) To UBound(arr, 2))

    For i = lngMin + baslikVar To lngMax - 1
        For j = i + 1 To lngMax
            hat1 = Replace(Left(arr(i, sutunNo), InStr(1, arr(i, sutunNo), "*") - 1), "Hat", "") +0 
            hat2 = Replace(Left(arr(j, sutunNo), InStr(1, arr(j, sutunNo), "*") - 1), "Hat", "") + 0
'            If arr(i, sutunNo) > arr(j, sutunNo) Then
            If hat1 > hat2 Then
                For k = LBound(arr, 2) To UBound(arr, 2)
                    strTemp(k) = arr(i, k)
                Next k
                For k = LBound(arr, 2) To UBound(arr, 2)
                    arr(i, k) = arr(j, k)
                Next k
                For k = LBound(arr, 2) To UBound(arr, 2)
                    arr(j, k) = strTemp(k)
                Next k
             
            End If
        Next j
    Next i

    DiziSIRALA = arr

End Function
 
Son düzenleme:
Hocam , Yeni bir kod yazmışsınız sayıları sıralamak için ama acele etmeden bir kaç sefer denedim . Ama Hat1*... den sonra Hat10*.. geliyor yani 1..2..3...diye sıralı değil , siz kodu yazdıktan sonra denemiş miydiniz?
 
Merhaba,
Bir şey deneme yaparken düzeltmeyi unutmuşum, yukarıdaki kodlardan sadece Function olanını almanız yeterli.
 
Merhaba Necdet Hocam ,
arD = DiziSIRALA(arD, 1, 1) bunu ve devamında ,

Public Function DiziSIRALA(arr As Variant, _
Optional baslikVar As Integer = 0, _
Optional sutunNo As Integer = 1) As Variant ,

bu kısmı anlamam ,daha doğrusu öğrenmem için bir kaynak ya da size sıkıntı olmayacaksa bilgilendirebilirmisiniz ?
 
Merhaba,
Public Function DiziSIRALA(arr As Variant, _
Optional baslikVar As Integer = 0, _
Optional sutunNo As Integer = 1) As Variant ,

dizisıralamanın fonksiyonlarıdır.
arr variant bir değişken, baslikvar integer degisken ve sutun no da yine integer değişken.
değişkenler optional ile başlıyor ve = ile devam ediyorsa bu parametrenin yazılması gerekmez, yazılmazsa olması gereken ilk değeri alır anlamında.
başlıkvar değişkenini yazmazsanız bu değişkenin değerini 0 kabul eder.
Kod: 
For i = lngMin + baslikVar To lngMax - 1
döngüdeki i dizinin ilk satırındran başlar, buna baslikvar değerini toplarsak başlık satırlarını sıralamadan diğer satırları sıralamaya yarar.

sutunNo da ise eğer dizinin ilk sütununa bakarak sıralama yapmak istiyorsanız bu değeri yazmasanız da olur otomatik olarak 1. sütundan başlasın diye seçenekli belirttim.

Diziler hızlıdır ama dizilerle de uğraşmak zordur. Üzerinde çalışmak gerek.
Bilmem bu bilgiler yarararlı oldu mu?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst