gruplama ve sıralama

[arzum2000]

Merhabalar,ekteki dosyaya A ve B sütunlarına veritabanından veri yazdırıyorum daha sonra bunları R4-aa44 formüllerle büyükten küçüğe doğru başharflerine göre sıralıyorum.Ancak veri tabanından A ve B sütununa veri yazdırırke dosya formüller nedeniyle kilitleniyor.Makro ile başka bir yolla yazılırsa sorun çözülebilir diye düşünüyorum.Yardımlarınızı bekliyorum.Tşkler.

 

[Ömer]

Merhaba,

Option Explicit
 
Sub GrupAyir()
Dim i, sat, son As Long, sut, j As Integer
Application.ScreenUpdating = False
Application.Calculation = xlManual
son = [A65536].End(3).Row
Range("D4:M" & son).ClearContents
For i = 4 To son
    sut = 0
    For j = 4 To 12 Step 2
        If Left(Cells(i, "A"), 1) = Left(Cells(2, j), 1) Then
            sut = j
            Exit For
        End If
    Next j
    If sut > 0 Then
        sat = Cells(65536, sut).End(3).Row + 1
        Cells(sat, sut) = Cells(i, "A")
        Cells(sat, sut + 1) = Cells(i, "B")
    End If
Next i
Range("D4:E" & son).Sort Range("D4"): Range("F4:G" & son).Sort Range("F4")
Range("H4:I" & son).Sort Range("I4"): Range("J4:K" & son).Sort Range("J4")
Range("L4:M" & son).Sort Range("L4")
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

Dosyanız ektedir.

.

 

[arzum2000]

Çok teşekkür ediyorum.Büyükten küçüğe doğru sıralama yapılabilirmi.

 

[arzum2000]

Büyükten küçüğe doğru sıralama yapılabilirmi?

 

[Ömer]

Eki inceleyin. Ayrıca, A sütununa yanlış veri giriş kontrolünü de ekledim.

.

 

[arzum2000]

sanırım yanlış anlaşıldı.Ben d4 ile m44 arasındaki kodlar ile süreleri büyükten küçüğe doğru sıralayabilirmiyiz diye sormuştum.Olursa tabi eğer olmassa bu şekildede işimi görür ama daha kolaylık olur benim için.

 

[Ömer]

Büyükten küçüğe sıralama yapıyor. Denemediniz mi?

.

 

[Ömer]

Süreye göre istemişsiniz. Yeni farkettim.

Kodları aşağıdaki gibi değiştirin.

Option Explicit
Sub GrupAyir()
Dim i, sat, son As Long, sut, j As Integer
Application.ScreenUpdating = False
Application.Calculation = xlManual
son = [A65536].End(3).Row
Range("D4:M" & son).ClearContents
Range("A4:B" & son).Interior.ColorIndex = 34
For i = 4 To son
    sut = 0
    For j = 4 To 12 Step 2
        If Left(Cells(i, "A"), 1) = Left(Cells(2, j), 1) Then
            sut = j
            Exit For
        End If
    Next j
    If sut > 0 Then
        sat = Cells(65536, sut).End(3).Row + 1
        Cells(sat, sut) = Cells(i, "A")
        Cells(sat, sut + 1) = Cells(i, "B")
     Else
        MsgBox Cells(i, "A") & " Değerinin Karşılığını Bulamadım, Satır Numarası : " & i
        Range("A" & i & ":B" & i).Interior.ColorIndex = 3
     End If
Next i
Range("D4:E" & son).Sort Range("E4"), xlDescending: Range("F4:G" & son).Sort Range("G4"), xlDescending
Range("H4:I" & son).Sort Range("I4"), xlDescending: Range("J4:K" & son).Sort Range("K4"), xlDescending
Range("L4:M" & son).Sort Range("M4"), xlDescending
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

.

 

[arzum2000]

Tamam şimdi oldu.Teşekkürlerimi iletiyorum.Kolay gelsin.