Kenarlık ve sıralama

[Szg15]

Merhabalar. Satır sayısı sürekli değişen RAPOR isimli bir sayfam var. B2:F2 aralığından aşağıya doğru iniyor ama kaçıncı satırda biteceği sürekli değişiyor.

Yapmak istediğim,
1- A2 hücresinden itibaren, dolu olan son satıra kadar (aşağıya doğru) 1’drn başlayacak şekile otomatik numaralandırsın,
2- A2:F2 aralığından itibaren dolu olan son satıra kadar kenarlık eklesin,
3-dolu olan son satırın 4 satır altına,
- B kolonuna denk gelen yere Sayfa 1’in sırasıyla A1,A2,A3 hücrelerinde yazanları alt alta;
-D kolonuna denk gelen yere Sayfa 1’in sırasıyla B1,B2,B3 hücrelerinde yazanları alt alta;
-F kolonuna denk gelen yere Sayfa 1’in sırasıyla C1,C2,C3 hücrelerinde yazanları alt alta getirsin.

Yardımcı olursanız çok sevinirim. Herkese şimdiden sağlıklı ve huzurlu yeni bir yıl dilerim.

 

[Szg15]

Merhabalar. Satır sayısı sürekli değişen RAPOR isimli bir sayfam var. B2:F2 aralığından aşağıya doğru iniyor ama kaçıncı satırda biteceği sürekli değişiyor.

Yapmak istediğim,
1- A2 hücresinden itibaren, dolu olan son satıra kadar (aşağıya doğru) 1’drn başlayacak şekile otomatik numaralandırsın,
2- A2:F2 aralığından itibaren dolu olan son satıra kadar kenarlık eklesin,
3-dolu olan son satırın 4 satır altına,
- B kolonuna denk gelen yere Sayfa 1’in sırasıyla A1,A2,A3 hücrelerinde yazanları alt alta;
-D kolonuna denk gelen yere Sayfa 1’in sırasıyla B1,B2,B3 hücrelerinde yazanları alt alta;
-F kolonuna denk gelen yere Sayfa 1’in sırasıyla C1,C2,C3 hücrelerinde yazanları alt alta getirsin.

Yardımcı olursanız çok sevinirim. Herkese şimdiden sağlıklı ve huzurlu yeni bir yıl dilerim.

Eklemeyi unutmuşum, bir de önce C, sonra D, sonra E, son olarak F sütunlarına göre sıralama yapması

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Bicimlendir()
    Dim Son As Long
    
    Son = Cells(Rows.Count, 3).End(3).Row
    
    With Range("A2:A" & Son)
        With ActiveSheet
            .Sort.SortFields.Clear
            .Sort.SortFields.Add Key:=Range("C2:C" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("D2:D" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("E2:E" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SortFields.Add Key:=Range("F2:F" & Son), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Sort.SetRange Range("A1:F" & Son)
            .Sort.Header = xlYes
            .Sort.MatchCase = False
            .Sort.Orientation = xlTopToBottom
            .Sort.SortMethod = xlPinYin
            .Sort.Apply
        End With
        
        .Formula = "=ROW()-1"
        .Value = .Value
        .Resize(, 6).Borders.LineStyle = 1
    
        .Offset(Son + 3, 1).Resize(3, 1).Value = Sheets("Sayfa1").Range("A1:A3").Value
        .Offset(Son + 3, 3).Resize(3, 1).Value = Sheets("Sayfa1").Range("B1:B3").Value
        .Offset(Son + 3, 5).Resize(3, 1).Value = Sheets("Sayfa1").Range("C1:C3").Value
    End With

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Szg15]

Deneyiniz.

Option Explicit

Sub Bicimlendir()
    Dim Son As Long
   
    Son = Cells(Rows.Count, 2).End(3).Row
    With Range("A2:A" & Son)
        .Formula = "=ROW()-1"
        .Value = .Value
        .Resize(, 6).Borders.LineStyle = 1
        .Offset(Son + 3, 1).Resize(3, 1).Value = Sheets("Sayfa1").Range("A1:A3").Value
        .Offset(Son + 3, 3).Resize(3, 1).Value = Sheets("Sayfa1").Range("B1:B3").Value
        .Offset(Son + 3, 5).Resize(3, 1).Value = Sheets("Sayfa1").Range("C1:C3").Value
    End With

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Teşekkür ederim hocam, mükemmel çalışıyor. Elleriniz dert görmesin.

 

[Szg15]

Teşekkür ederim hocam, mükemmel çalışıyor. Elleriniz dert görmesin.

hocam sıralamayı yapmıyormuş şimdi farkettim

 

[Korhan Ayhan]

#3 nolu mesajımda ki kodu güncelledim. Tekrar deneyiniz.

 

[Szg15]

#3 nolu mesajımda ki kodu güncelledim. Tekrar deneyiniz.

Tekrar teşekkür ederim hocam, çalışıyor, elinize sağlık.