Snasui Excel Forum

Code: Select all

Public Sub compareprocap() 'refferenccompare
              Application.ScreenUpdating = False
              ActiveWorkbook.Sheets("MPS COMPARE").Activate
                        Dim rAll As Range, r As Range
                        Dim colR As Collection, item As Variant
                        Dim subTotal As Double, target As Range
                        Dim iMax As Integer, icount As Integer
                        Set colR = New Collection
                        Dim grandTotal As Double
                        Dim grand2 As Double
                        Dim grand3 As Double
                            grandTotal = 0
                        With Sheets("NEWDATA")
                            Set rAll = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
                        End With
                        On Error Resume Next
                        For Each r In rAll
                            colR.Add r, r 'row number null
                        Next r
                        On Error GoTo 0   'debug error
                        
                        For Each item In colR
                            iMax = Application.CountIf(rAll, item)
                            icount = 0
                            subTotal = 0
                            For Each r In rAll
                                If r <> "" Then
                                    With Sheets("MPS COMPARE")
                                        Set target = .Range("a" & Range("a99999").End(xlUp).Row).Offset(1, 0) 'set target
                                    End With
                                    
                                    If r = item Then
                                        Rows(target.Row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'insert row
                                        
                                        target.Offset(-1, 0) = r
                                        target.Offset(-1, 0).Offset(0, 1) = r.Offset(0, 1) 'count colum capacity
                                         target.Offset(-1, 0).Offset(0, 1).Font.Bold = True
                                          target.Offset(-1, 0).Offset(0, 1).Offset(0, 1) = r.Offset(0, 1).Offset(0, 1) 'form_fac
                                          Cells(6, 3) = "FORM_FACTOR"
                                        subTotal = subTotal + r.Offset(0, 1)
                                        icount = icount + 1
                                    End If
                                    If icount = iMax Then
                                        Rows(target.Row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'insert row
                                        
                                        With Sheets("MPS COMPARE").Range("a" & Range("a99999").End(xlUp).Row)
                                            .Offset(1, 0) = r + " Total"
                                            .Offset(1, 0).Font.Bold = True
                                            .Offset(1, 1).Font.Color = -10477568
                                            .Offset(1, 1).Font.Bold = True
                                            grandTotal = grandTotal
                                            subTotal = 0
                                        End With
                                        With Sheets("MPS COMPARE")
                                            Range("a" & target.Row - 1 & ":e" & target.Row - 1).Interior.Color = 13434777  'format paint
                                        End With
                                        Exit For
                                    Else
                                    End If
                                End If
                             Next r
                             grandTotal = grandTotal
                        Next item
                        With Sheets("MPS COMPARE").Range("a" & Rows.Count).End(xlUp)
                            .Offset(1, 0) = "Grand Total"
                             .Offset(1, 0).Font.Bold = True
                            .Offset(1, 1).Font.Color = 15773696
                            .Offset(1, 1).Font.Bold = True
        
                         
                            .Offset(1, 0).Offset(1, 0) = "Grand Total 2.5"
                             .Offset(1, 0).Offset(1, 0).Font.Bold = True
                             .Offset(1, 0).Offset(1, 0).Offset(1, 0) = "Grand Total 3.5"
                             .Offset(1, 0).Offset(1, 0).Offset(1, 0).Font.Bold = True

                           
                        End With
                        
                        With Sheets("MPS COMPARE")
                            Range("a" & target.Row & ":e" & target.Row).Interior.Color = 49407
                           
                        End With
                        
                          Columns("C:C").Select
    Selection.NumberFormat = "0.0;[Red]0.0"
                        
                        Application.ScreenUpdating = True
End Sub

Code: Select all

Option Explicit
Public Function compareprocap() 'refferenccompare
              Application.ScreenUpdating = False
              ActiveWorkbook.Sheets("MPS COMPARE").Activate
                        Dim rAll As Range, r As Range
                        Dim colR As Collection, item As Variant
                        Dim subTotal As Double, target As Range
                        Dim iMax As Integer, icount As Integer
                        Set colR = New Collection
                        Dim grandTotal As Double
                        Dim grand2 As Double
                        Dim grand3 As Double
                            grandTotal = 0
                        With Sheets("NEWDATA")
                            Set rAll = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
                        End With
                        On Error Resume Next
                        For Each r In rAll
                            colR.Add r, r 'row number null
                        Next r
                        On Error GoTo 0   'debug error
                        
                        For Each item In colR
                            iMax = Application.CountIf(rAll, item)
                            icount = 0
                            subTotal = 0
                            For Each r In rAll
                                If r <> "" Then
                                    With Sheets("MPS COMPARE")
                                        Set target = .Range("a" & Range("a99999").End(xlUp).Row).Offset(1, 0) 'set target
                                    End With
                                    
                                    If r = item Then
                                        Rows(target.Row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'insert row
                                        
                                        target.Offset(-1, 0) = r
                                        target.Offset(-1, 0).Offset(0, 1) = r.Offset(0, 1) 'count colum capacity
                                         target.Offset(-1, 0).Offset(0, 1).Font.Bold = True
                                          target.Offset(-1, 0).Offset(0, 1).Offset(0, 1) = r.Offset(0, 1).Offset(0, 1) 'form_fac
                                        
                                        subTotal = subTotal + r.Offset(0, 1)
                                        icount = icount + 1
                                    End If
                                    If icount = iMax Then
                                        Rows(target.Row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'insert row
                                        
                                        With Sheets("MPS COMPARE").Range("a" & Range("a99999").End(xlUp).Row)
                                            .Offset(1, 0) = r + " Total"
                                            .Offset(1, 0).Font.Bold = True
                                            .Offset(1, 1).Font.Color = -10477568
                                            .Offset(1, 1).Font.Bold = True
                                            grandTotal = grandTotal
                                            subTotal = 0
                                        End With
                                        With Sheets("MPS COMPARE")
                                            Range("a" & target.Row - 1 & ":e" & target.Row - 1).Interior.Color = 13434777  'format paint
                                        End With
                                        Exit For
                                    Else
                                    End If
                                End If
                             Next r
                             grandTotal = grandTotal
                        Next item
                        With Sheets("MPS COMPARE").Range("a" & Rows.Count).End(xlUp)
                            .Offset(1, 0) = "Grand Total"
                             .Offset(1, 0).Font.Bold = True
                            .Offset(1, 1).Font.Color = 15773696
                            .Offset(1, 1).Font.Bold = True
        
                         
                            .Offset(1, 0).Offset(1, 0) = "Grand Total 2.5"
                             .Offset(1, 0).Offset(1, 0).Font.Bold = True
                             .Offset(1, 0).Offset(1, 0).Offset(1, 0) = "Grand Total 3.5"
                             .Offset(1, 0).Offset(1, 0).Offset(1, 0).Font.Bold = True
                           
                        End With
                        
                        With Sheets("MPS COMPARE")
                            Range("a" & target.Row & ":e" & target.Row).Interior.Color = 49407
                            For Each r In Range("A2", Range("A" & Rows.Count).End(xlUp))
                                If r = "Grand Total 2.5" Then
                                    r.Resize(1, 5).Interior.Color = 49407
                                End If
                                If r = "Grand Total 3.5" Then
                                    r.Resize(1, 5).Interior.Color = 49407
                                End If
                            Next r
                        End With
                        
                          Columns("C:C").Select
    Selection.NumberFormat = "0.0;[Red]0.0"
                        
                        Application.ScreenUpdating = True
End Function

Code: Select all

Sub test()
Dim r As Range
Dim lr As Long, lngRow As Long, lngStart As Long
Application.ScreenUpdating = False
With Sheets("NEWDATA")
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    Range("A2:C" & lr).Copy Sheets("MPS COMPARE").Range("A2")
End With
Sheets("MPS COMPARE").Activate
lr = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & lr).Copy Sheets("MPS COMPARE").Range("F1")
Range("F1:F" & lr).RemoveDuplicates Columns:=1, Header:=xlNo
Range("F1:F" & lr).Sort Columns(6), xlAscending
Range("F1:G1").Insert Shift:=xlDown
Range("G1").FormulaR1C1 = "=SUM(C[-5])"
Range("G2").FormulaR1C1 = "=SUMIFS(C[-5],C[-4],RC[-1])"
Range("G2").AutoFill Destination:=Range("G2:G" & Range("F" & Rows.Count).End(xlUp).Row)
With Range("G1", Range("G" & Rows.Count).End(xlUp))
    .Value = .Value
End With
For Each r In Range("G1", Range("G" & Rows.Count).End(xlUp))
    If r <> "" Then
        r.Offset(0, -1) = "Grand Total" & " " & r.Offset(0, -1)
    End If
Next r
lngStart = 2: lngRow = lngStart
Do: lngRow = lngRow + 1
    If Range("A" & lngRow) <> Range("A" & lngRow - 1) Then
        Rows(lngRow).Insert
        Range("B" & lngRow) = "=SUM(B" & lngStart & ":B" & lngRow - 1 & ")"
        Range("A" & lngRow).Value = Range("A" & lngRow - 1) & " " & "Total"
        Range("A" & lngRow).Resize(1, 5).Interior.Color = 13434777
        lngRow = lngRow + 1: lngStart = lngRow
    End If
Loop Until Range("B" & lngRow) = ""
For Each r In Range("F1", Range("F" & Rows.Count).End(xlUp))
    If r <> "" Then
        r.Resize(1, 2).Copy Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    End If
Next r
For Each r In Range("A1", Range("A" & Rows.Count).End(xlUp))
    If Left(r, 5) = "Grand" Then
        r.Resize(1, 5).Interior.Color = 49407
    End If
Next r
Columns("F:G").ClearContents
Columns("A:E").AutoFit
Range("A1").Activate
Application.ScreenUpdating = True
End Sub