Her Sıralama Altında Toplam almak!

S

shenko

Katılım
23 Şubat 2006
Mesajlar
176
Excel Vers. ve Dili
Excell 2003
Değerli arkadaşlar,

Aşağıda yine sizlerin yardımlarıyla yapılan bir makro var.

Sizinde anlayabildiğiniz gibi aşağıdaki makro; verilen dataları ilk önce "arial" yazısına çeviriyor daha sonra "w7" ye göre sıralıyor ve sıralamadan sonra her ilk yazının birincisini "Arial Black" olarak değiştiriyor.

Örneğin: a (birinci a'yı "Arial Black" olarak değiştirir.)
a
a
a
b (birinci b'yi "Arial Black" olarak değiştirir.)
b
Şimdi bu makroya alt toplam eklemek istiyorum! Yani a'ların bittiği satırın altına bir boş satır ekleyip X sutununda alt toplam alıcak, b'lerin bittiği satırın altına boş satır ekleyip b'lerin alt toplamını yine x sutununa alıcak!!!

Not: Dosyam çok büyük olduğu için ekleyemedim. Bilginize...

İliginize çok Teşşekkürler

Range("T2").Select
son = [T65536].End(3).Row
Range("T7:AL" & son).Select
Selection.Font.Name = "Arial"
Selection.Sort Key1:=Range("W7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Cells(7, 23).Font.Name = "Arial Black"
For x = 7 To son - 1
If Cells(x, 23) <> Cells(x + 1, 23) Then Cells(x + 1, 23).Font.Name = "Arial Black"
Next
son = [AO65536].End(3).Row
For x = 7 To son
If Range("W" & x).Font.Name = "Arial Black" Then
Range("T" & x - 1 & ":AL" & x - 1).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
End If

Next
MsgBox "ALICILAR'A GÖRE SIRALANDI!"
End Sub
 
S

shenko

Katılım
23 Şubat 2006
Mesajlar
176
Excel Vers. ve Dili
Excell 2003
Aradaşlar yapmak istediğime benzer örnek bi dosya ekliyorum..

Yardımcı olursanız çok minnettar olucam..


Saygılar....
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,301
Excel Vers. ve Dili
Ofis 365 Türkçe
Umarım doğru anlamışımdır.

Ekteki dosyayı inceleyiniz
 
Son düzenleme:
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,746
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Selamlar,

A&#351;a&#287;&#305;daki kodu denermisiniz.

Kod: 
Sub D&#220;ZENLE()
    Application.ScreenUpdating = False
    Columns("A:C").RemoveSubtotal
    [A2:C65536].Clear
    [G2:I100].Copy [A2]
    With Range("A2:C65536").Font
        .Name = "Arial"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("A2:C100").Sort Key1:=Range("A2"), Order1:=xlAscending
    For X = [A65536].End(3).Row To 2 Step -1
    If Cells(X, 1) <> Cells(X - 1, 1) Then
    Cells(X, 1).Font.Name = "Arial Black"
    End If: Next
    Columns("A:C").Subtotal GroupBy:=1, Function:=xlSum, _
    TotalList:=Array(3), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    Application.ScreenUpdating = True
End Sub
 
S

shenko

Katılım
23 Şubat 2006
Mesajlar
176
Excel Vers. ve Dili
Excell 2003
Say&#305;n Cost_Control,

verdi&#287;iniz makro i&#351;e yar&#305;yor fakat bo&#351;luk b&#305;rakt&#305;&#287;&#305;nda yan tarafta bulanan di&#287;er ana listeyide bozuyor. Acaba araya ara toplamlar&#305; al&#305;rken sat&#305;r ekletmeden yapabilirmiyiz. mesela ilk&#246;nce "a" lar&#305; s&#305;rala alt&#305;na aratoplam al, "b" leri s&#305;rala alt&#305;na ara toplam al &#351;eklinde makro yazabilirmiyiz???
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,746
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Selamlar,

A&#351;a&#287;&#305;daki kodu denermisiniz.

Kod: 
Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    [A2:C65536].Clear
    [G2:I100].Copy [A2]
    With Range("A2:C65536").Font
        .Name = "Arial"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range("A2:C100").Sort Key1:=Range("A2"), Order1:=xlAscending
    For X = [A65536].End(3).Row To 3 Step -1
    If Cells(X, 1) <> Cells(X - 1, 1) Then
    Cells(X, 1).Font.Name = "Arial Black"
    With Range("A" & X - 1 & ":C" & X - 1).Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThick
    .ColorIndex = xlAutomatic
    End With
    Range("A" & X & ":C" & X).Insert
    End If: Next
    For Each ALAN In Columns("C:C").SpecialCells(xlCellTypeConstants, 1).Areas
    ALAN.Offset(ALAN.Count, 0).Resize(1, 1) = WorksheetFunction.Sum(Range(ALAN.Address))
    ALAN.Offset(ALAN.Count, 0).Resize(1, 1).Font.Bold = True
    Next
    Application.ScreenUpdating = True
    MsgBox "&#304;&#350;LEM&#304;N&#304;Z TAMAMLANMI&#350;TIR.", vbInformation
End Sub
 
Son düzenleme:
S

shenko

Katılım
23 Şubat 2006
Mesajlar
176
Excel Vers. ve Dili
Excell 2003
Say&#305;n Cost_Control verdi&#287;iniz makro tam istedi&#287;im gibi &#231;al&#305;&#351;&#305;yor. Ellerinize sa&#287;l&#305;k &#231;ok&#231;ok te&#351;ekk&#252;r ederim. Yaln&#305;z ben kendi dosyama uyarlayamad&#305;m makronuzu. Acaba sizin yazd&#305;&#287;&#305;n&#305;z makro i&#231;indeki alt toplamlar&#305; ald&#305;ran k&#305;s&#305;m hangisidir?ben sadece o k&#305;sm&#305; eklesem yeterli olurmu acaba? A&#351;a&#287;&#305;da dosyamda &#231;al&#305;&#351;an makroyu g&#246;nderiyorum. Yard&#305;mc&#305; olabilirseniz sevinirim.. Tekrar te&#351;ekk&#252;rler!
Sub Macro1()

Range("U7:AL500").Select
Selection.ClearContents
Range("B7:S500").Copy
Range("U7").PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Selection.Sort Key1:=Range("W7"), Order1:=xlAscending, Key2:=Range("U7") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
Range("T7:AL500").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDash
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlDash
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Range("T2").Select
son = [T65536].End(3).Row
Range("T7:AL" & son).Select
Selection.Font.Name = "Arial"
Selection.Sort Key1:=Range("W7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Cells(7, 23).Font.Name = "Arial Black"
For X = 7 To son - 1
If Cells(X, 23) <> Cells(X + 1, 23) Then Cells(X + 1, 23).Font.Name = "Arial Black"
Next
son = [AO65536].End(3).Row
For X = 7 To son
If Range("W" & X).Font.Name = "Arial Black" Then
Range("T" & X - 1 & ":AL" & X - 1).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
End If

Next
MsgBox "ALICILAR'A G&#214;RE SIRALANDI!"
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,746
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Selamlar,

Dosyan&#305;z&#305; eklermisiniz.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,746
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Selamlar,

A&#351;a&#287;&#305;daki kodlar&#305; denermisiniz.

Kod: 
Sub ALICILARA_G&#214;RE_SIRALA()
    Application.ScreenUpdating = False
    Range("T7:AL500").Select
    Selection.ClearContents
    Range("A7:S500").Copy
    Range("T7").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("W7"), Order1:=xlAscending, Key2:=Range("U7") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom
    Range("T7:AL500").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThick
    .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlMedium
    .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThick
    .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = xlAutomatic
    End With
    
    Range("T7").Select
    SON = [U65536].End(3).Row
    Range("T7:AL" & SON).Select
    Selection.Font.Name = "Arial"
    Selection.Sort Key1:=Range("W7"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Cells(7, 23).Font.Name = "Arial Black"
    For X = 7 To SON
    If Cells(X + 1, 23) <> "" Then
    If Cells(X, 23) <> Cells(X + 1, 23) Then Cells(X + 1, 23).Font.Name = "Arial Black"
    End If
    Next
   
    Range("T7").Formula = "=IF(U7="""","""",IF(W7=W6,T6+1,1))"
    Range("T7").AutoFill Destination:=Range("T7:T" & SON), Type:=xlFillDefault
    Range("T7:T" & SON).Value = Range("T7:T" & SON).Value
    
    For X = SON To 8 Step -1
    If Cells(X, 23).Font.Name = "Arial Black" Then
    Range("T" & X & ":AL" & X).Insert
    With Range("T" & X & ":AL" & X).Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThick
    .ColorIndex = xlAutomatic
    End With
    End If: Next
    
    For Each ALAN In [AK7:AK65536].SpecialCells(xlCellTypeConstants, 1).Areas
    ALAN.Offset(ALAN.Count, 0).Resize(1, 1) = WorksheetFunction.Sum(Range(ALAN.Address))
    ALAN.Offset(ALAN.Count, 0).Resize(1, 1).Font.Name = "Arial Black"
    Next
    Range("T7").Select
    Application.ScreenUpdating = True
    MsgBox "ALICILAR'A G&#214;RE SIRALANDI!"
End Sub
Kod: 
Sub SATICILARA_G&#214;RE_SIRALA()
    Application.ScreenUpdating = False
    Range("AM7:BE500").Select
    Selection.ClearContents
    Range("A7:S500").Copy
    Range("AM7").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("AO7"), Order1:=xlAscending, Key2:=Range("AN7") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom
    Range("AM7:BE500").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlThick
    .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlMedium
    .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlThick
    .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlDash
    .Weight = xlThin
    .ColorIndex = xlAutomatic
    End With
    
    Range("AM7").Select
    SON = [AN65536].End(3).Row
    Range("AM7:BE" & SON).Select
    Selection.Font.Name = "Arial"
    Selection.Sort Key1:=Range("AO7"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Cells(7, 41).Font.Name = "Arial Black"
    For X = 7 To SON
    If Cells(X + 1, 41) <> "" Then
    If Cells(X, 41) <> Cells(X + 1, 41) Then Cells(X + 1, 41).Font.Name = "Arial Black"
    End If
    Next
   
    Range("AM7").Formula = "=IF(AN7="""","""",IF(AO7=AO6,AM6+1,1))"
    Range("AM7").AutoFill Destination:=Range("AM7:AM" & SON), Type:=xlFillDefault
    Range("AM7:AM" & SON).Value = Range("AM7:AM" & SON).Value
    
    For X = SON To 8 Step -1
    If Cells(X, 41).Font.Name = "Arial Black" Then
    Range("AM" & X & ":BE" & X).Insert
    With Range("AM" & X & ":BE" & X).Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThick
    .ColorIndex = xlAutomatic
    End With
    End If: Next
    
    For Each ALAN In [BD7:BD65536].SpecialCells(xlCellTypeConstants, 1).Areas
    ALAN.Offset(ALAN.Count, 0).Resize(1, 1) = WorksheetFunction.Sum(Range(ALAN.Address))
    ALAN.Offset(ALAN.Count, 0).Resize(1, 1).Font.Name = "Arial Black"
    Next
    Range("AM7").Select
    Application.ScreenUpdating = True
    MsgBox "SATICILAR'A G&#214;RE SIRALANDI!"
End Sub
 
S

shenko

Katılım
23 Şubat 2006
Mesajlar
176
Excel Vers. ve Dili
Excell 2003
Sayın Cost Control,

Emeğinize, elinize sağlık. Çok guzel bir çalışma oldu.

Çok teşekkür ederim, sabrınız ve diğer herşey için...

Saygılar..
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst