• DİKKAT

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

özel sıralama listeme buton atayamıyorum!

Katılım
8 Nisan 2024
Mesajlar
17
Excel Vers. ve Dili
microsoft Office Professional Plus 2019
Merhabalar işim gereği tüm gün excel deyim desem yeridir. Turizm, yolcu taşımacılığı yapıyorum. kendi sistemimizden excel olarak aldığım yolcu listelerindeki araçların gideceği otelleri önce birleştirip sonra, özel sıralama ile kolayca sıraya diziyorum buraya kadar bir sorunum yok. ancak her seferinde sıralama > özel sıralama > sıralama ölçütü > düzen den kendi özel listemi seçmek biraz vaktimi alıyor. Her seferinde aynı bloklar ile çalıştığım için, bir düğme atayıp hızlıca bu işimi halletmek istiyorum. internetten çok izledim ancak bu işlem için yapamadım.Hata veriyor, sıralamıyor. yardımcı olabilecek varmıdır?

ÖRNEK LİSTEM:
https://ibb.co/TwNhgCh
 
Son düzenleme:
Merhaba örnek dosyanızı eklerseniz yardımcı olan çıkacaktır.
 
Merhaba,
Kırmızı renkli satırda bölünme olmuş. O satırı yukarıdaki satırın sonuna alın.
, DataOption:=xlSortNormal

Dedıgınız gibi yaptım ama her seferınde aynı satırda yapıyor bu işleri. ben seçip tuşa basınca seçtiğim kısmı sıralamasını istiyordum.
 
Resim değilde örnek dosya yüklerseniz daha kolay sonuç alabiliriz.
 
https://s6.dosya.tc/server19/428vh9/ORNEK.XLS.html

ÖRNEK DOSYAM BUDUR. UCAK SAATLERINE GÖRE AYIRDIGIM BÖLÜMLERİ, OTEL SIRALAMASINA GÖRE DÜĞME İLE DİZMEK İSTİYORUM. OTEL SIRA LİSTEM FILAN HAZIR DİZEBİLİYORUM AMA BEN BU İŞLEMİ TEK DÜĞME İLE YAPMAK İSTİYORUM.
 
Merhaba,

Sanıyorum Capslock tuşunuz açık kaldı..

Bir kuralı hatırlatmakta fayda var..

Büyük Harf Kısıtlaması:
- Mesaj yazarken büyük harf kullanmak bağırmak anlamına geleceği için yazılarınızı kesinlikle büyük harf kullanarak yazmayınız.
 
Kriterler sayfası oluşturup A1:A ya sıralamanızı yerleştirip kodu çalıştırın.
Kod:
Sub test()
    Dim strOrder, area, rng
    With Sheets("Kriterler")
        strOrder = Join(Application.Transpose(.Range("A1:A" & .Cells(Rows.Count, 1).End(3).Row)), ",")
    End With

    With Worksheets("Transfer Takip Formu")
        With .Range("F3:F" & .Cells(Rows.Count, "F").End(3).Row).SpecialCells(xlCellTypeConstants)
            For Each area In .Areas
                Set rng = area.Offset(, -5).Resize(, 7)
                With rng.Parent.Sort
                    .SortFields.Clear
                    .SortFields.Add Key:=area, SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, DataOption:=xlSortNormal, _
                                    CustomOrder:=CVar(strOrder)
                    .SetRange rng
                    .Header = xlGuess
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
            Next area
        End With
    End With

End Sub
 
Kriterler sayfası oluşturup A1:A ya sıralamanızı yerleştirip kodu çalıştırın.
Kod:
Sub test()
    Dim strOrder, area, rng
    With Sheets("Kriterler")
        strOrder = Join(Application.Transpose(.Range("A1:A" & .Cells(Rows.Count, 1).End(3).Row)), ",")
    End With

    With Worksheets("Transfer Takip Formu")
        With .Range("F3:F" & .Cells(Rows.Count, "F").End(3).Row).SpecialCells(xlCellTypeConstants)
            For Each area In .Areas
                Set rng = area.Offset(, -5).Resize(, 7)
                With rng.Parent.Sort
                    .SortFields.Clear
                    .SortFields.Add Key:=area, SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, DataOption:=xlSortNormal, _
                                    CustomOrder:=CVar(strOrder)
                    .SetRange rng
                    .Header = xlGuess
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
            Next area
        End With
    End With

End Sub

vallahi bu işte baya bi yeniyimde beceremedim.sıralama listem bu şekilde çıkıyor bunu nereye kopyalıyacağım tam olarak.


"ADB DEPAR,KUSADASI GOLF RESORT,FAUSTINA HOTEL,AKBULUT,GREEN GOLD GÜZELCAMLI,GRAND BELISH HOTEL,FLORA GARDEN EPHESUS,DAVUTLAR PALM WINGS BEACH RESORT,FLORA SUITES HOTEL KUSADASI,ATLANTIQUE HOLIDAY CLUB,MY AEGEAN STAR HOTEL KUSADASI,SENTINUS BEACH HOTEL,BATIHAN OTEL,EPHESIA HOTEL,EPHESIA HOLIDAY BEACH,UNIQUE LIFE STYLE,GRAND SAHINS HOTEL,SIGNATURE BLUE RESORT,FANTASIA" & _
" DE LUXE HOTEL KUSADASI,PALMIN HOTEL,OPUS APARTMENTS KUSADASI,MARBEL HOTEL BY PALM WINGS,LIBERTY KUSADASI,OTIUM SEALIGHT RESORT,GRAND BLUE SKY HOTEL,LE BLEU HOTEL & RESORT,INFINITY BY YELKEN (EX IMBAT),MARTI BEACH HOTEL,TUNTAS FAMILY SUITES KUSADASI,PONZ BOUTIQUE HOTEL KUSADASI,ASENA HOTEL,ROSY SUITES,ALTINSARAY HOTEL,SURTEL HOTEL,ILAYDA AVANTGARDE,DERICI HOTEL,ILAY" & _
"DA HOTEL,HOTEL BY KARAASLAN INN,PALM HOTEL KUSADASI,PALOMA MARINA SUITES,CASA DEL SOLE HOTEL,THE CITYS HILL HOTEL,CHARISMA DE LUXE,KORUMAR HOTEL DE LUXE,LADONIA HOTELS ADAKULE,RAMADA SUITES KUSADASI,RAMADA RESORT BY WYNDHAM KUSADASI AND GOLF,KUSTUR CLUB HOLIDAY VILLAGE,TUSAN BEACH RESORT,PINE BAY HOLIDAY RESORT,LABRANDA EPHESUS PRINCESS KUSADASI,AQUA FANTASY HOTEL,P" & _
"ALM WINGS EPHESUS BEACH RESORT,RICHMOND EPHESUS RESORT,KORUMAR EPHESUS BEACH & SPA RESORT HOTEL,ARIA CLAROS BEACH & SPA RESORT,SUNIS EFES ROYAL PALACE RESORT & SPA,NOTION KESRE BEACH HOTEL & SPA OZDERE,KARYA FAMILY RESORT,CLUB BEYY RESORT HOTEL,KARYA FAMILY RESORT,CLUB MARVY,GRAND EFE HOTEL,PALOMA PASHA,DOGAN PARADISE,DOGAN BEACH RESORT & SPA OZDERE,CACTUS PARADISE " & _
"BEACH,GUMULDUR RESORT HOTEL GRAND SAHINS,CACTUS CLUB YALI HOTELS & RESORT GUMULDUR,MAYA BISTRO HOTEL BEACH,CLUB RESORT ATLANTIS SEFERIHISAR,LEBEDOS PRINCESS SEFERIHISAR,ANGORA BEACH RESORT" & _
""
 
Kod:
Sub test()
    Dim strOrder, area, rng

    strOrder = "ADB DEPAR,KUSADASI GOLF RESORT,FAUSTINA HOTEL,AKBULUT,GREEN GOLD GÜZELCAMLI,GRAND BELISH HOTEL,FLORA GARDEN EPHESUS,DAVUTLAR PALM WINGS BEACH RESORT,FLORA SUITES HOTEL KUSADASI,ATLANTIQUE HOLIDAY CLUB,MY AEGEAN STAR HOTEL KUSADASI,SENTINUS BEACH HOTEL,BATIHAN OTEL,EPHESIA HOTEL,EPHESIA HOLIDAY BEACH,UNIQUE LIFE STYLE,GRAND SAHINS HOTEL,SIGNATURE BLUE RESORT,FANTASIA" & _
               " DE LUXE HOTEL KUSADASI,PALMIN HOTEL,OPUS APARTMENTS KUSADASI,MARBEL HOTEL BY PALM WINGS,LIBERTY KUSADASI,OTIUM SEALIGHT RESORT,GRAND BLUE SKY HOTEL,LE BLEU HOTEL & RESORT,INFINITY BY YELKEN (EX IMBAT),MARTI BEACH HOTEL,TUNTAS FAMILY SUITES KUSADASI,PONZ BOUTIQUE HOTEL KUSADASI,ASENA HOTEL,ROSY SUITES,ALTINSARAY HOTEL,SURTEL HOTEL,ILAYDA AVANTGARDE,DERICI HOTEL,ILAY" & _
               "DA HOTEL,HOTEL BY KARAASLAN INN,PALM HOTEL KUSADASI,PALOMA MARINA SUITES,CASA DEL SOLE HOTEL,THE CITYS HILL HOTEL,CHARISMA DE LUXE,KORUMAR HOTEL DE LUXE,LADONIA HOTELS ADAKULE,RAMADA SUITES KUSADASI,RAMADA RESORT BY WYNDHAM KUSADASI AND GOLF,KUSTUR CLUB HOLIDAY VILLAGE,TUSAN BEACH RESORT,PINE BAY HOLIDAY RESORT,LABRANDA EPHESUS PRINCESS KUSADASI,AQUA FANTASY HOTEL,P" & _
               "ALM WINGS EPHESUS BEACH RESORT,RICHMOND EPHESUS RESORT,KORUMAR EPHESUS BEACH & SPA RESORT HOTEL,ARIA CLAROS BEACH & SPA RESORT,SUNIS EFES ROYAL PALACE RESORT & SPA,NOTION KESRE BEACH HOTEL & SPA OZDERE,KARYA FAMILY RESORT,CLUB BEYY RESORT HOTEL,KARYA FAMILY RESORT,CLUB MARVY,GRAND EFE HOTEL,PALOMA PASHA,DOGAN PARADISE,DOGAN BEACH RESORT & SPA OZDERE,CACTUS PARADISE " & _
               "BEACH,GUMULDUR RESORT HOTEL GRAND SAHINS,CACTUS CLUB YALI HOTELS & RESORT GUMULDUR,MAYA BISTRO HOTEL BEACH,CLUB RESORT ATLANTIS SEFERIHISAR,LEBEDOS PRINCESS SEFERIHISAR,ANGORA BEACH RESORT" & _
               ""

    With Worksheets("Transfer Takip Formu")
        With .Range("F3:F" & .Cells(Rows.Count, "F").End(3).Row).SpecialCells(xlCellTypeConstants)
            For Each area In .Areas
                Set rng = area.Offset(, -5).Resize(, 7)
                With rng.Parent.Sort
                    .SortFields.Clear
                    .SortFields.Add2 Key:=area, SortOn:=xlSortOnValues, _
                                    Order:=xlAscending, DataOption:=xlSortNormal, _
                                    CustomOrder:=CVar(strOrder)
                    .SortFields.Add2 Key:=area.Offset(, 1), _
                                     SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                    .SetRange rng
                    .Header = xlGuess
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
            Next area
        End With
    End With

End Sub
 
Geri
Üst