Kritere Göre Sayfa Sıralama Hk.

I

ikeremk

Katılım
25 Haziran 2013
Mesajlar
5
Excel Vers. ve Dili
Excel 2010
İngilizce
Merhaba,

Uzun zamandır uğraşmama rağmen beceremediğim bir konu var. Yardımınıza ihtiyacım var.
Excel dosyam var, orda her bir sayfa için bir risk skoru mevcut. Bu risk skoruna göre sayfa numaralarını sıralamak istiyorum.
Yani :

En büyük risk skoru 25-20-15-12 vs diye gidiyor 1'e kadar. Ben çıktı aldığımda 1. sayfa numarasında 25 lerin olmasını istiyorum.Büyükten küçüğe doğru sıralama yapıcak ve ona göre çıktı alıcak.
Örneğin 4 tane 25 risk skoru var ise bunları en yukarıya atıcak 1-2-3-4. sayfa bunlar olucak, sonra 20 risk skoru var ise bunu getiricek. Çıktı bu şekilde almak istiyorum.

Ekte dosyayı gönderdim. Zaten görüceksiniz risk sokurunu, yalnız 2 tane risk skoru olan kısım var. üstteki olan alınacak yani genel olarak büyük rakamların olduğu hücre baz alınacak.

Bunu otomatik olarakda sağlayabiliriz, yoksa bir butonda koyulabilir. Buton koyulursa daha iyi olur. SIRALA şeklinde butona bastığında, ona göre sıralama yapar ve çıktıyı alırız.
Sanıyorum ne istediğimi anlatabildim.

İster o şekilde çıktı aldırabiliriz , ister bir başka excel dosyasına belirttiğim şekilde sıralanmasını sağlayabiliriz.
Yardımcı olursanız sevinirim.

DOSYA ;
http://dosya.co/av8ro77y8rg7/Pep-Enerji-Risk-Analizi.rar.html
 
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,670
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
Kontrol ediniz.

RiskSıralı sayfası her defasından yeniden oluşturulmaktadır.

https://upterabit.com/1Kjx/Pep-Enerji-Risk-Analizi.xlsm


Kod: 
Dim veriliste(10000, 3) As String
Dim say As Long
Dim ustorta1, ustorta2, ustsag1, ustsag2 As String


Sub menu()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  ustorta1 = [B8]
  ustorta2 = [B9] & "    "
  ustsag1 = [B12]
  ustsag2 = [B13]
  
  Call veri_al
  Call degeryaz
  Call sirali_olustur
  Call Yazici_Ayarla
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Sub DeleteHeadersFooters()

  With ActiveSheet.PageSetup

    .LeftHeader = ""
    .CenterHeader = ""
    .RightHeader = ""

    .LeftFooter = ""
    .CenterFooter = ""
    .RightFooter = ""

 End With

End Sub

Sub Yazici_Ayarla()
    Sheets("RiskSıralı").Select
    Call DeleteHeadersFooters
    'ustorta1 = "orta deneem1"
    'ustorta2 = "orta deneem2"
    'ustsag1 = "DENEME TARİHİ :"
    'ustsag2 = "10.01.2018"
    
    
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False

    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "&""-,Kalın""&13  &""+,Kalın""" & ustorta1 & Chr(10) & ustorta2 & Chr(10) & """"
        .RightHeader = ustsag1 & Chr(10) & ustsag2
        .LeftFooter = ""
        .CenterFooter = "&10SAYFA : &P / &N"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.196850393700787)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.118110236220472)
        .BottomMargin = Application.InchesToPoints(0.551181102362205)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub


Sub sirali_olustur()
  baslayeni = 0
  For i = 1 To say
    Sheets("Risk").Select
    basla = veriliste(i, 2)
    bitir = veriliste(i, 3)

    Rows(basla & ":" & bitir).Select
    Selection.Copy
    Sheets("RiskSıralı").Select
    If baslayeni = 0 Then baslayeni = 1 Else baslayeni = baslayeni + 39
    Rows(baslayeni).Select
    
    ActiveSheet.Paste

    Columns(1).ColumnWidth = 0.67 'A
    Columns(2).ColumnWidth = 8.43 'B
    Columns(3).ColumnWidth = 3.43 'C
    Columns(4).ColumnWidth = 8.43 'D
    Columns(5).ColumnWidth = 4.14 'E
    Columns(6).ColumnWidth = 8.43 'f
    Columns(7).ColumnWidth = 8.43 'g
    Columns(8).ColumnWidth = 1.14 'h
    Columns(9).ColumnWidth = 8.43 'I
    Columns(10).ColumnWidth = 8.43 'J
    Columns(11).ColumnWidth = 8.43 'K
    Columns(12).ColumnWidth = 8.43 'L
    Columns(13).ColumnWidth = 8.43 'M
    Columns(14).ColumnWidth = 8.43 'N
    Columns(15).ColumnWidth = 7.86 'O
    Columns(16).ColumnWidth = 7.14  'P
    Columns(17).ColumnWidth = 21.57  'Q
    Columns(18).ColumnWidth = 1.29  'R
    Columns(19).ColumnWidth = 8.43  'S
    Cells(baslayeni + 5, 2).Value = i
  Next i
  
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

Sub siralama()
    Range("A1").Select
    ActiveWorkbook.Worksheets("RiskSıralı").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("RiskSıralı").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("RiskSıralı").Sort
        .SetRange Range("A:C")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub degeryaz()
  If WorksheetExists("RiskSıralı") Then Sheets("RiskSıralı").Delete
  Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
  NewSh.Name = "RiskSıralı"

  For i = 1 To say
    Cells(i, 1).Value = veriliste(i, 1)
    Cells(i, 2).Value = veriliste(i, 2)
    Cells(i, 3).Value = veriliste(i, 3)
  Next i
  
  Call siralama
  
  For i = 1 To say
    veriliste(i, 1) = Cells(i, 1).Value
    veriliste(i, 2) = Cells(i, 2).Value
    veriliste(i, 3) = Cells(i, 3).Value
  Next i
  
  Columns("A:C").Select
  Selection.ClearContents
  Range("A1").Select
End Sub

Sub veri_al()
   Sheets("Risk").Select
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   say = 0
   basla = 1
   bitir = 1
   For i = 1 To sonsatir
     mevcutrisk = Cells(i, 2).Value
     isguvenligi = Cells(i, 1).Value
     If InStr(mevcutrisk, "Mevcut Risk") > 0 Then
        i = i + 1
        Risk = Cells(i, 7).Value
     End If
     
     If InStr(isguvenligi, "İŞ GÜVENLİĞİ UZMANI") > 0 Then
        i = i + 3
        bitir = i
        say = say + 1
        veriliste(say, 1) = Risk
        veriliste(say, 2) = basla
        veriliste(say, 3) = bitir
        basla = i + 1
        Risk = 0
     End If
   Next i
      
End Sub
 
Son düzenleme:
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,670
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
ikeremk' Alıntı:
Ellerinize , emeğiniz sağlık. Çok teşekkür ederim.

Birkaç düzeltme ile ilgili mail gönderdim, kontrol edip dönüş yaparsanız mutlu olurum :)
Genişletmek için tıkla ...
Programda 10000 adet risk sıralayabilirsiniz. Bunun haricinde bir sınırlama yok.
Bu değeri arttırmak isterseniz ilk satırdaki 10000 i değiştirin.

Program B kolonundaki son dolu hücreye göre işlem yapıyordu. Bu yüzden son risk tablosunu sıralamıyordu. A kolonundaki son dolu hücreye göre işlem sağlandı.

Bu şekilde tüm tabloları alacaktır.
 
I

ikeremk

Katılım
25 Haziran 2013
Mesajlar
5
Excel Vers. ve Dili
Excel 2010
İngilizce
asri' Alıntı:
Programda 10000 adet risk sıralayabilirsiniz. Bunun haricinde bir sınırlama yok.
Bu değeri arttırmak isterseniz ilk satırdaki 10000 i değiştirin.

Program B kolonundaki son dolu hücreye göre işlem yapıyordu. Bu yüzden son risk tablosunu sıralamıyordu. A kolonundaki son dolu hücreye göre işlem sağlandı.

Bu şekilde tüm tabloları alacaktır.
Genişletmek için tıkla ...
Merhaba ilginize tşkler, evet artık risk eklendiğinde onuda sıralamaya alıyor sıkıntı yok.
Şimdi sizi yoruyorum ama bilmiyorum müsait zamanınız varmı ;
2 Adet sıkıntım var ;
1 - Yeni sıralanmış listede, risklerin NO kısmı var. haliyle şuan sıraladığımız zaman risk puanı yüksek olan en başa geliyor, onun numarası kaç ise örneğin 8 numara en başa gelmiş oluyor. Yeni sıralanan listede, yeni sıralamaya göre NO'larıda 1'den başlatma şansımız varmı otomatik olarak 1-2-3... diye gitsin.
2 - Diğer bir problem ise sayfa düzeni, hücre genişliği vs kayboluyor yeni aktardığımızda, sanıyorum sadece satır yüksekliği ayarlanmış, satır yükksekliği aynı geliyor fakat sutunların genişliği aynı gelmiyor.Onu nasıl ayarlabiliriz.

Çok yordum sizi kusura bakmayınız lütfen.
 
I

ikeremk

Katılım
25 Haziran 2013
Mesajlar
5
Excel Vers. ve Dili
Excel 2010
İngilizce
Birde üst bilgi kısmı kayboluyor yeni sıralanan listede, eklemek istediğimde ekleyemiyorum üst bilgiyi.
 
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,670
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
ikeremk' Alıntı:
Birde üst bilgi kısmı kayboluyor yeni sıralanan listede, eklemek istediğimde ekleyemiyorum üst bilgiyi.
Genişletmek için tıkla ...
Sıra numarası, kolon genişlikleri eklendi.
Üst bilgi değişken olarak tanımlandı. Üst bilgi bilgilerini ana sayfada giriniz.
 
I

ikeremk

Katılım
25 Haziran 2013
Mesajlar
5
Excel Vers. ve Dili
Excel 2010
İngilizce
asri' Alıntı:
Sıra numarası, kolon genişlikleri eklendi.
Üst bilgi değişken olarak tanımlandı. Üst bilgi bilgilerini ana sayfada giriniz.
Genişletmek için tıkla ...
Hocam Merhaba, size bir mail gönderdim.Dosya ile ilgili bir sıkıntım var. Yardımcı olursanız sevinirim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst