Koşullu-Sıralı Liste

alozan · 25 Mart 2016

Elimde 5 adet kritere göre hazırlanmış kaynak bir tablo bulunmakta. Yapmak istediğim kriterlerden birine göre filtrelemek(Story) ve geri kalanını her kriter için A'dan Z'ye sıralamak, exceldeki veri filtreleme gibi bir şey yani. Ekteki örnekte sağda kaynak tablom bulunmakta, solda ise elde etmek istediğim tablo bulunmaktadır. Oluşturmak için 5-10 tane benzersiz liste forum konusunu inceledim ama maalesef yapamadım. Bu işlemi yapmam için gerekli formüller konusunda bile yardımcı olabilirseniz çok sevinirim.
(Benim sorunuma uyarlayabileceğim bir örneği dosyanın sağ tarafında verdim ama maalesef bu örneğe filtreyi ekleyemedim.)

http://www.dosya.tc/server7/wniupd/EXCEL_SORU.xls.html

Asri · 25 Mart 2016

N4 hücresine filtre için kod girin.
N4 Hücresi her değiştiğinde tablo güncellenecektir.

Olmayan bir kod girildiğinde tablo sıfırlanacaktır.

http://s8.dosya.tc/server2/qm2n0m/Macro_Filtre.xls.html

alozan · 25 Mart 2016

Yardımınız için çok teşekkür ediyorum. Emeğinize sağlık. Allah razı olsun

savas_145 · 25 Mart 2016

sadece formüllerle yapılmış hali
http://s8.dosya.tc/server2/deuc2t/EXCEL_SORU.xls.html

alozan · 25 Mart 2016

Savaş Bey yardımınız için çok teşekkür ederim, ellerinize sağlık. Ama hazırlamış olduğunuz excel formülleri benim bilgimin 2-3 beden üstü gibi uyarlamak dahi uyarlayamıyorum, o yüzden kodlar daha bir anlaşılır geldi. Sayın Asri bey size sormak istediğim bu formulü nasıl çoğaltabilirim? Aşağıda resim ve kodla anlatmaya çalıştım.

İhtiyacım: Sizin yapmış olduğunuz filtrelemeyi "N5" hücresine de uygulamam ve verileri de P4 ile başlayan kısma yerleştirtmem. Sizin yaptığınız kodu bu şekilde N6, N7 diye sağa doğru giden tablolar halinde yapmaya çalışıyorum.

Sizin yapmış olduğunuz kod ;

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("N4")) Is Nothing Then Exit Sub
    Call menu
End Sub

Sub menu()
  Call filtrele
  Call sirala
End Sub

Sub filtrele()
  kriter = Cells(4, "N").Value
  satir = 3
  sonsatir = [H65536].End(3).Row
  secim = "B4:F" & sonsatir
  Range(secim).Select
  Selection.ClearContents
  Range("B4").Select
    
  For i = 4 To sonsatir
    story = Cells(i, "H").Value
    pier = Cells(i, "I").Value
    loadcombo = Cells(i, "J").Value
    Location = Cells(i, "K").Value
    v2 = Cells(i, "L").Value
    
    If story = kriter Then
      satir = satir + 1
      Cells(satir, "B").Value = story
      Cells(satir, "C").Value = pier
      Cells(satir, "D").Value = loadcombo
      Cells(satir, "E").Value = Location
      Cells(satir, "F").Value = v2
    End If
 Next i
 
End Sub


Sub sirala()
     sonsatir = [B65536].End(3).Row
     secim = "B3:F" & sonsatir
     secimb = "B4:B" & sonsatir
     secimc = "C4:C" & sonsatir
     secimd = "D4:D" & sonsatir
     secime = "E4:E" & sonsatir
     secimf = "F4:F" & sonsatir
     
    Range(secim).Select
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimb), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimd), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secime), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimf), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort
        .SetRange Range(secim)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("N4").Select
End Sub

Benim düzeltmeye çalıştığım ama hata veren kod:

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("N4")) Is Nothing Then Exit Sub
    Call menu
End Sub

Sub menu()
  Call filtrele
  Call sirala
End Sub

Sub filtrele()
  kriter = Cells(4, "N").Value
  satir = 3
  sonsatir = [H65536].End(3).Row
  secim = "B4:F" & sonsatir
  Range(secim).Select
  Selection.ClearContents
  Range("B4").Select
    
  For i = 4 To sonsatir
    story = Cells(i, "H").Value
    pier = Cells(i, "I").Value
    loadcombo = Cells(i, "J").Value
    Location = Cells(i, "K").Value
    v2 = Cells(i, "L").Value
    
    If story = kriter Then
      satir = satir + 1
      Cells(satir, "B").Value = story
      Cells(satir, "C").Value = pier
      Cells(satir, "D").Value = loadcombo
      Cells(satir, "E").Value = Location
      Cells(satir, "F").Value = v2
    End If
 Next i
 
End Sub


Sub sirala()
     sonsatir = [B65536].End(3).Row
     secim = "B3:F" & sonsatir
     secimb = "B4:B" & sonsatir
     secimc = "C4:C" & sonsatir
     secimd = "D4:D" & sonsatir
     secime = "E4:E" & sonsatir
     secimf = "F4:F" & sonsatir
     
    Range(secim).Select
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimb), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimd), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secime), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimf), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort
        .SetRange Range(secim)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("N4").Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("N5")) Is Nothing Then Exit Sub
    Call menu1
End Sub

Sub menu1()
  Call filtrele1
  Call sirala1
End Sub

Sub filtrele1()
  kriter = Cells(5, "N").Value
  satir = 3
  sonsatir = [H65536].End(3).Row
  secim = "P4:T" & sonsatir
  Range(secim).Select
  Selection.ClearContents
  Range("P4").Select
    
  For i = 4 To sonsatir
    story = Cells(i, "H").Value
    pier = Cells(i, "I").Value
    loadcombo = Cells(i, "J").Value
    Location = Cells(i, "K").Value
    v2 = Cells(i, "L").Value
    
    If story = kriter Then
      satir = satir + 1
      Cells(satir, "P").Value = story
      Cells(satir, "Q").Value = pier
      Cells(satir, "R").Value = loadcombo
      Cells(satir, "S").Value = Location
      Cells(satir, "T").Value = v2
    End If
 Next i
 
End Sub


Sub sirala1()
     sonsatir = [B65536].End(3).Row
     secim = "P3:T" & sonsatir
     secimb = "P4:P" & sonsatir
     secimc = "Q4:Q" & sonsatir
     secimd = "R4:R" & sonsatir
     secime = "S4:S" & sonsatir
     secimf = "T4:T" & sonsatir
     
    Range(secim).Select
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimb), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimd), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secime), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort.SortFields.Add Key:= _
        Range(secimf), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("TRANSFER KAT CALISMASI").Sort
        .SetRange Range(secim)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("N5").Select
End Sub

Asri · 26 Mart 2016

100 tabloya kadar kriter girebilir siniz.
Dosya yapısını değiştirdim. Kod kopyala yapıştır ile çalışmayacaktır.
Dosyayı indirmeniz gerekiyor.

Her kriter bağımsız çalışmaktadır. Hangi kriteri değiştirirseniz sadece onun tablosu güncellenir.

Buradaki H100 ile kriter sayısını azaltıp çoğaltabilir siniz.

If Intersect(Target, Range("H4:H100")) Is Nothing Then Exit Sub

http://s6.dosya.tc/server6/enwekb/Macro_Filtre.xls.html

Kod:

Dim kritersira, kritersutun, tablo As Integer
Dim kriter As String



Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("H4:H100")) Is Nothing Then Exit Sub
    
     kritersira = Target.Row - 3
     kriter = Target.Value
     kritersutun = ((kritersira * 6) + 10) - 6
     
     Range("B2:F3").Select
     Selection.Copy
     Cells(2, kritersutun).Select
     ActiveSheet.Paste
     Range("J5").Select
     Call menu
     Target.Select
     
End Sub

Sub menu()
  Call filtrele
End Sub

Sub filtrele()
  satir = 3
  sonsatir = Cells(Rows.Count, kritersutun).End(xlUp).Row

  If sonsatir > 3 Then
    Range(Cells(4, kritersutun), Cells(sonsatir, kritersutun + 4)).Select
    Selection.ClearContents
    Range("H4").Select
  End If
  
  sonsatir = Cells(Rows.Count, 2).End(xlUp).Row
  For i = 4 To sonsatir
    story = Cells(i, "B").Value
    pier = Cells(i, "C").Value
    loadcombo = Cells(i, "D").Value
    Location = Cells(i, "E").Value
    v2 = Cells(i, "F").Value
    
    If story = kriter Then
      satir = satir + 1
      Cells(satir, kritersutun).Value = story
      Cells(satir, kritersutun + 1).Value = pier
      Cells(satir, kritersutun + 2).Value = loadcombo
      Cells(satir, kritersutun + 3).Value = Location
      Cells(satir, kritersutun + 4).Value = v2
    End If
 Next i
 
  If satir > 3 Then
    Range("B4:F4").Select
    Selection.Copy
    Range(Cells(4, kritersutun), Cells(satir, kritersutun + 4)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("L12").Select
  End If
  
End Sub

alozan · 26 Mart 2016

Sayın Asri Bey,

İlginiz ve yardımınız için çok teşekkür ediyorum, vermiş olduğunuz bu kodlarla beraber çalışıp dosyamı tamamlamaya çalışacağım. Allah sizden razı olsun

Asri · 26 Mart 2016

Allah sizden de razı olsun.