• DİKKAT

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

Sıralama hk.

V

valentino06

Katılım
19 Şubat 2007
Mesajlar
630
Excel Vers. ve Dili
Ofis 365 Tr- 64 Bit
Merhaba,
Arkadaşlar ekteki dosyada "B" Sütunundaki verileri koyu renkte olan verinin altına sıralı olarak gelmesini istiyorum. lütfen yardımcı olabilir misiniz.
 

Ekli dosyalar

Arkadaşlar lütfen yardımlarınızı bekliyorum. hayırlı akşamlar dilerim.
 
Merhaba.

Biraz dolambaçlı ancak sonuç alınıyor.

Aşağıdaki kod'u sayfanın kod bölümüne uygulayın ve çalıtırın.
Azalan sıralama (A sütunundaki Sipariş Numarası üzerinden)
için Ascending kısmını Descending olarak değiştirebilirsiniz.

Ayrıca kod I sütununda formül uygulayarak çalıştığından bu sütunda verileriniz varsa onları başka sütuna alınız.
Kod: 
[FONT="Arial Narrow"]Sub GRUP_SIRALA_BRN()
Application.ScreenUpdating = False
brn = Cells(65536, 8).End(3).Row
    With Range("I7:I" & brn)
        .Formula = "=IF(OR(A7=0,A7=""""),I6,A7)" ': .Value = .Value
    End With
Range("A6:I" & brn).Sort Key1:=[I6], Order1:=xlAscending, Header:=xlGuess
    Columns("I:I").ClearContents
    Range("B1").Select
Application.ScreenUpdating = True
MsgBox "Sıralama Tamam"
End Sub[/FONT]
 
Son düzenleme:
Merhaba,
Ömer bey yardımlarınız için çok teşekkür ederim. aşağıya doğru incelediğimde "B"sütunu hepsini sıralamıyor.Halit beyin daha önce yardımcı olmuş olduğu kod var fakat yeni excel çalışma sayfasında verileri siliyor. kodu ekleyeyim incelermisiniz.
Kod: 
Sub sirala()

ZBasla = TimeValue(Now)
zaman = Timer

sut1 = "a" 'başlangıç sutün
sut2 = "b" 'Taranacak sutün
sut3 = "K" 'yardımcı sutün

sat1 = 7 'başlangıç satır


Set Sh1 = Sheets(ActiveSheet.Name) 'sayfa adı
son = Sh1.Cells(Rows.Count, sut1).End(3).Row 'son dolu satır

Sh1.Range(Sh1.Cells(sat1, sut3), Sh1.Cells(son, sut3)).Clear


Range(sut2 & sat1 & ":" & sut2 & son).Copy
Cells(7, sut3).PasteSpecial Paste:=2
Application.CutCopyMode = False

For j = sat1 To son

deg2 = Split(Sh1.Cells(j, sut2), "KG")
If UBound(deg2) > 0 Then
deg3 = deg2(0) & "KG" & Format(deg2(1), "000")
End If
Sh1.Cells(j, sut2) = deg3 '"h" & Format(deg3, "0000000000000")
Next j

Range("A7:" & sut3 & son).Sort Key1:=Cells(7, sut2), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

Range(sut3 & sat1 & ":" & sut3 & son).Copy
Cells(7, sut2).PasteSpecial Paste:=2
Application.CutCopyMode = False
    
Range("a1").Select


Sh1.Range(Sh1.Cells(sat1, sut3), Sh1.Cells(son, sut3)).Clear
zBitis = TimeValue(Now)
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub
 
Önceki cevabımı güncelledim, tekrar kontrol ediniz.
Dikkatimden kaçan hususu düzelttim.
Sadece I ve J sütunları kullanılıyor, K sütununa gerek kalmadı.
Sanırım şimdi tamam.
 
ömer bey yine sıralamayı atlamış çok özür diliyorum sizleri değerli vaktinizi aldığım için.çok af edersiniz.
MTL-820.KG75
S-07067-1)
S-07067-3)
U120-15-200-200)
MTL-823.KG20
S-14030-1)
S-14030-2)
S-14030-3)
S-14030-4)
MTL-820.KG76
S-07066-1)
S-07066-3)
U120-15-200-200)
MTL-820.KG77
S-07071-1)
S-07071-2)
S-07071-4)
U120-15-200-200)
MTL-823.KG21
S-14009-1)
S-14009-2)
H120-15-200-200)
MTL-820.KG78
S-07072-1)
S-07072-2)
S-07072-3)
S-07072-6)
S-07072-7)
U120-15-200-200)
MTL-823.KG22
S-14013-1)
S-14013-2)
MTL-823.KG23
S-14018-1)
S-14018-2)
MTL-823.KG24
S-14010-1)
S-14010-2)
S-14010-3)
S-14010-4)
S-14010-5)
MTL-820.KG79
S-07073-1)
S-07073-2)
S-07073-5)
S-07073-6)
U120-15-200-200)
MTL-823.KG25
 
Tekrar merhaba.

Sanırım yanlış anlıyorum.
Benim anladığım mevcut listenin (A:H sütun aralığı) A sütunundaki ürün kodları (ilgili boş hücrelerle birlikte)
kriterine göre sırılama yapılmak istendiği şeklinde.

Uygulanmış dosya ekte yer alıyor. Sıralama kriterini seçerek sonucu görebilirsiniz.
.
 

Ekli dosyalar

Son düzenleme:
merhaba,
Ömer bey sizi yorduğumun farkındayım fakat ekte sarı ile boyadım sizde göreceksinizki atlıyor ve sıralama tam olmuyor.
 

Ekli dosyalar

Merhaba,
Ömer bey son göndermiş olduğun Excel kitabında diğer makroları da çalıştırmıyor. Ömer bey Halit beyin makrosu silmese çok güzel sıralıyordu. fakat neden siliyor anlamış değilim
 
Merhaba.

Gönderdiğim belgede sıralama kriteri olarak kullanılan bilgi A sütunundaki bilgilerdir.
.
Kod: 
        .Formula = "=IF(OR(A7=0,A7=""""),I6,[B][COLOR="Red"]A[/COLOR][/B]7)": .Value = .Value
Eğer istediğiniz A sütununun dolu olduğu satırlarda yer alan B sütunundaki bilgilere göre sıralama yapılması ise;
yukarıdaki kod satırındaki kırmızı renklendirdiğim A sütun adını B olarak değiştirmeniz yeterli olur.
 
Ömer bey sizin değerli vaktinizi aldığımı biliyorum ama sıralamayı hatalı yapıyor.
 
Eklediğiniz örnek belgede elle sıralama yaparak olması gerekeni oluştururduktan sonra yeni belge eklerseniz, deneme ve kontrol etme şansım olur, yoksa oluyor/olmuyor sistemiyle sonuca ulaşmam biraz zor.
Çünkü belge sizin ve olması gerekeni siz biliyorsunuz.
 
merhaba,
Ömer bey eklediğim örnek dosyada sıralamanın nasıl olacağını sarı ile boyadım.
 

Ekli dosyalar

14 nolu dosyanızdaki sıralama kodu bende çalışıyor.
 
Merhaba,
Halit bey ekteki Excel sayfasında sizin Makronuz haricinde 2 adet daha makro var. bu makroları control shift +Z Olan formatı oluşturmak için 2. ise "A" Sütunundaki 20000 lerin haricindekileri silmek için.bu iki işlemi yaptıktan sonra sizin daha önce bana yapmış olduğunuz sıralama makrosunu bu formata uygulamaya çalışıyorum. fakat verileri siliyor. ben size diğer formatı da ekliyeceğim.
 

Ekli dosyalar

3.xls yi a sütünundan itibaren örnek dosya yapıştırsanız ve control shift Z Çalıştırırsanız ne demek istediğimi anlıyacaksınız. ve diğer makroyu control shift X Yaparsanız 20000 lerin haricindeki siliyor.
 
sil makrosu yerine bu makroyu kullanın ve sonrada sıralama makrosunu kullanın

Kod: 
Sub Makro1()

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
 .Calculation = xlManual
End With

ZBasla = TimeValue(Now)
zaman = Timer

sut1 = "a" 'başlangıç sutün
sut4 = "L" 'yardımcı sutün

sat1 = 7 'başlangıç satır
aranan = "2000000"

Set Sh1 = Sheets(ActiveSheet.Name) 'sayfa adı
son = Sh1.Cells(Rows.Count, sut1).End(3).Row 'son dolu satır

For j = sat1 To son
deg2 = Split(Sh1.Cells(j, sut1), aranan)
If UBound(deg2) > 0 Then
deg3 = deg2(1)
End If
Sh1.Cells(j, sut4).Value = Val(aranan & deg3) * 1 '"h" & Format(deg3, "0000000000000")
Sh1.Cells(j, sut4).NumberFormat = "0"
Next j


For j = son To sat1 Step -1
If Left(Sh1.Cells(j, sut4).Value, Len(aranan)) <> aranan Then
Rows(j).Delete Shift:=xlUp
End If
Next j

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
  .Calculation = xlAutomatic
End With

End Sub
 
Merhaba,
Halit bey eve geldim. evden denedim. 2000000 ler kalacaktı diğerlerini yani boş olanları silecekti ve sıralama yaptığım zamanda toplam 2000 16 adet var sadece 5 tane kalmış 11 taneyi silmiş 2 pozu da sıralamamış Halit bey K sütunu da 2000 ler yazılı olarak kaldı tekrar ekliyorum görmeniz açısından Allah sizden kat kat razı olsun. gerçekten değerli zamanızı ayırdığınız için çok teşekkür ederim.
 

Ekli dosyalar

Birde bu silme kodunu dene

Kod: 
Sub Makro1()

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
 .Calculation = xlManual
End With

ZBasla = TimeValue(Now)
zaman = Timer

sut1 = "a" 'başlangıç sutün
sut4 = "L" 'yardımcı sutün

sat1 = 7 'başlangıç satır
aranan = "2000000"

Set Sh1 = Sheets(ActiveSheet.Name) 'sayfa adı
son = Sh1.Cells(Rows.Count, sut1).End(3).Row 'son dolu satır

veri2 = "hhhhhhhhhhhh"

For j = sat1 To son
If Len(Sh1.Cells(j, sut1).Value) > 1 Then
veri1 = Sh1.Cells(j, sut1)
veri2 = veri1
End If
Sh1.Cells(j, sut4).Value = veri2

Next j


For j = son To sat1 Step -1
If Left(Sh1.Cells(j, sut4).Value, Len(aranan)) <> aranan Then
Rows(j).Delete Shift:=xlUp
End If
Next j

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
  .Calculation = xlAutomatic
End With

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst