TİF Fişi Kontrolu

[Yesilyurtlu]

Uzmanlarım;
Gruplandırma yapmadan makro ile otomotik olarak ekli dosyada sayfa1 de B sütununda ki Düzey detay kodu değiştiği zaman sayfa 2 deki gibi kırmızı renkli toplamları yapabilme imkanımız varmıdır?
Varsa Yardımcı olabilir misiniz?

 

[Ömer]

Merhaba,

Bence veri / alttoplam menüsünü kullanmanız çok daha mantıklıdır.

Sizin istediğiniz yol ile yapılmıştır...

Module kopyalarak çalıştırınız.

Option Explicit
 
Sub GrupTopla()
 
    Dim i As Long
 
    Application.ScreenUpdating = False
    On Error Resume Next
 
    Range("A4:A" & Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("B4:G" & Rows.Count).Sort Range("B4")
 
    With Range("A4:G" & Rows.Count)
        .Font.ColorIndex = 0
        .Font.Bold = False
    End With
 
    For i = Cells(Rows.Count, "B").End(xlUp).Row To 4 Step -1
        If Cells(i, "B") <> Cells(i + 1, "B") Then
 
            Rows(i + 1).Insert Shift:=xlDown
            Cells(i, "B").Copy Cells(i + 1, "B")
 
            Cells(i + 1, "E") = Evaluate("=SumIf(B4:B" & i & ",B" & i + 1 & ",E4:E" & i & ")")
            Cells(i + 1, "F") = Evaluate("=SumIf(B4:B" & i & ",B" & i + 1 & ",F4:F" & i & ")")
            Cells(i + 1, "G") = Evaluate("=SumIf(B4:B" & i & ",B" & i + 1 & ",G4:G" & i & ")")
 
            With Range("B" & i + 1 & ":G" & i + 1)
                .Font.ColorIndex = 3
                .Font.Bold = True
            End With
 
        End If
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

 

[Altay3555]

Merhaba,

Bence veri / alttoplam menüsünü kullanmanız çok daha mantıklıdır.

Sizin istediğiniz yol ile yapılmıştır...

Module kopyalarak çalıştırınız.

Option Explicit
 .......
....... 
End Sub

Hocam Selamlar,
Emeğinize sağlık
Selamlar.

 

[Yesilyurtlu]

Ömer Abi Allah ne muradın vara versin.

Teşekkür Ederim Abi