Snasui Excel Forum

Code: Select all

Option Explicit
Dim grandTotal As Double
Public Function compareprocap()
              ActiveWorkbook.Sheets("MPS TEMPLATE").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
                            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   ' loop for add
                            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 TEMPLATE")
                                        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
                                    
                                        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 TEMPLATE").Range("a" & Range("a99999").End(xlUp).Row)
                                            .Offset(1, 0) = "Sub Total"
                                            .Offset(1, 1).Font.Color = -10477568
                                            .Offset(1, 1).Font.Bold = True
                                            grandTotal = grandTotal
                                            subTotal = 0
                                        End With
                                        With Sheets("MPS TEMPLATE")
                                            Range("a" & target.Row - 1 & ":n" & target.Row - 1).Interior.Color = 13434777
                                        End With
                                        Exit For
                                    Else
                                    End If
                                End If
                             Next r
                             grandTotal = grandTotal
                        Next item
                        With Sheets("MPS TEMPLATE").Range("a" & Rows.Count).End(xlUp)
                            .Offset(1, 0) = "Grand Total"
                    
                            .Offset(1, 1).Font.Color = 15773696
                            .Offset(1, 1).Font.Bold = True
                        End With
                        With Sheets("MPS TEMPLATE")
                            Range("a" & target.Row & ":n" & target.Row).Interior.Color = 49407
                        End With
End Function

Code: Select all

Public Sub compareprocap()
...
End Sub

Code: Select all

Dim grandTotal As Double
Public Function compareprocap()
              ActiveWorkbook.Sheets("MPS TEMPLATE").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
                            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                        Next r
                        On Error GoTo 0                           
                        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 TEMPLATE")
                                        Set target = .Range("a" & Range("a99999").End(xlUp).row).Offset(1, 0)                                 
    End With
                                    
                                    If r = item Then
                                        Rows(target.row).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow                                         
                                        target.Offset(-1, 0) = r
                                        target.Offset(-1, 0).Offset(0, 1) = r.Offset(0, 1) 'count colum capacity
                                        
                                        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 TEMPLATE").Range("a" & Range("a99999").End(xlUp).row)
                                            .Offset(1, 0) = "Sub Total"
                                            .Offset(1, 1).Font.Color = -10477568
                                            .Offset(1, 1).Font.Bold = True
                                            grandTotal = grandTotal
                                            subTotal = 0
                                        End With
                                        With Sheets("MPS TEMPLATE")
                                            Range("a" & target.row - 1 & ":n" & target.row - 1).Interior.Color = 13434777
                                        End With
                                        Exit For
                                    Else
                                    End If
                                End If
                             Next r
                             grandTotal = grandTotal
                        Next item
                        With Sheets("MPS TEMPLATE").Range("a" & Rows.Count).End(xlUp)
                            .Offset(1, 0) = "Grand Total"
                    
                            .Offset(1, 1).Font.Color = 15773696
                            .Offset(1, 1).Font.Bold = True
                        End With
                        With Sheets("MPS TEMPLATE")
                            Range("a" & target.row & ":n" & target.row).Interior.Color = 49407
                        End With
End Function

Code: Select all

Public Function compareFmonth1mps1() 'Fmonth1mps1
Dim i, j, x As Integer
Dim Fmonth() As String
Dim pro As String
Dim cap As String
Dim pro2() As String
Dim cap2() As String
Dim commit() As String
Dim no_c, no_d As Single

    i = 1
    no_c = 0
    Do Until Worksheets("summary1").Cells(i + 1, 1).Value & Worksheets("summary1").Cells(i + 1, 2).Value = ""
        
        i = i + 1
        no_c = no_c + 1
        
    Loop
    i = 1
     no_d = 0
    Do Until Worksheets("MPS TEMPLATE").Cells(i + 6, 1).Value & Worksheets("MPS TEMPLATE").Cells(i + 6, 2).Value = ""
        
        i = i + 1
        no_d = no_d + 1
        
    Loop
ReDim pro2(1 To no_d)
ReDim cap2(1 To no_d)
ReDim Fmonth(1 To no_c)
ReDim commit(1 To no_c)
i = 1
    For i = 1 To no_d
    ActiveWorkbook.Sheets("MPS TEMPLATE").Activate
       pro2(i) = Worksheets("MPS TEMPLATE").Cells(6 + i, 1).Value
       cap2(i) = Worksheets("MPS TEMPLATE").Cells(6 + i, 2).Value
Next i
i = 1
    For i = 1 To no_c
    
       pro = Worksheets("summary1").Cells(i + 1, 1).Value
       cap = Worksheets("summary1").Cells(i + 1, 2).Value
       Fmonth(i) = Worksheets("summary1").Cells(i + 1, 3).Value
       commit(i) = Worksheets("summary1").Cells(i + 1, 5).Value
      
    
   j = 1
  For j = 1 To no_d
   
     If (Fmonth(i) = Worksheets("MPS TEMPLATE").Cells(6, 3).Value) And (pro = pro2(j)) And (cap = cap2(j)) Then
       
        
        Worksheets("MPS TEMPLATE").Cells(6 + j, 3).Value = commit(i)
        x = 1
   Exit For
 
   
        
   Else
   

     x = 0
   
     End If
    Next j
    

    Next i
    
    
   
  
End Function

Code: Select all

Dim i, j, x As Integer

Code: Select all

Dim i as integer, j as integer, x As Integer

Code: Select all

Public Sub sumcommit() 'Fmonth1mps1
Dim i As Integer, j As Integer, x As Integer
Dim Fmonth() As String
Dim pro As String
Dim cap As String
Dim pro2() As String
Dim cap2() As String
Dim commit() As String
Dim no_c As Single, no_d As Single

    i = 1
    no_c = 0
    Do Until Worksheets("summary1").Cells(i + 1, 1).Value & Worksheets("summary1").Cells(i + 1, 2).Value = ""
        
        i = i + 1
        no_c = no_c + 1
        
    Loop
    i = 1
     no_d = 0
    Do Until Worksheets("MPS TEMPLATE").Cells(i + 6, 1).Value & Worksheets("MPS TEMPLATE").Cells(i + 6, 2).Value = ""
        
        i = i + 1
        no_d = no_d + 1
        
    Loop
ReDim pro2(1 To no_d)
ReDim cap2(1 To no_d)
ReDim Fmonth(1 To no_c)
ReDim commit(1 To no_c)
i = 1
    For i = 1 To no_d
    ActiveWorkbook.Sheets("MPS TEMPLATE").Activate
       pro2(i) = Worksheets("MPS TEMPLATE").Cells(6 + i, 1).Value
       cap2(i) = Worksheets("MPS TEMPLATE").Cells(6 + i, 2).Value
Next i
i = 1
    For i = 1 To no_c
    
       pro = Worksheets("summary1").Cells(i + 1, 1).Value
       cap = Worksheets("summary1").Cells(i + 1, 2).Value
       Fmonth(i) = Worksheets("summary1").Cells(i + 1, 3).Value
       commit(i) = Worksheets("summary1").Cells(i + 1, 5).Value
      
    
   j = 1
  For j = 1 To no_d
   
     If (Fmonth(i) = Worksheets("MPS TEMPLATE").Cells(6, 3).Value) And (pro = pro2(j)) And (cap = cap2(j)) Then
       
        
        Worksheets("MPS TEMPLATE").Cells(6 + j, 3).Value = commit(i)
        x = 1
   Exit For
 
   
        
   Else
   

     x = 0
   
     End If
    Next j
    

    Next i
    
    
End Sub

Code: Select all

Sub Test00()
    Dim rAll As Range
    Dim r As Range
    Dim subTotal As Double
    Dim grandToal As Double
    With Sheets("MPS TEMPLATE")
        Set rAll = .Range("a7", .Range("a" & .Rows.Count).End(xlUp))
    End With
    For Each r In rAll
        If InStr(r.Value, "Sub Total") = 0 Then
            If r.Offset(0, 2) = "" Then
                r.Offset(0, 2) = 0
            Else
                subTotal = subTotal + r.Offset(0, 2)
            End If
        ElseIf InStr(r.Value, "Sub Total") > 0 Then
            r.Offset(0, 2) = subTotal
            grandTotal = grandTotal + subTotal
            subTotal = 0
        End If
        If InStr(r.Value, "Grand Total") > 0 Then
            r.Offset(0, 2) = grandTotal
        End If
    Next r
End Sub

Code: Select all

Public Function comparefmonth1mps1()
Dim i As Integer, x As Integer, j As Integer
Dim Fmonth() As String
Dim pro As String
Dim cap As String
Dim pro2() As String
Dim cap2() As String
Dim commit() As String
Dim no_c As Single, no_d As Single, sum As Single, total As Single


    i = 1
    no_c = 0
    Do Until Worksheets("summary1").Cells(i + 1, 1).Value & Worksheets("summary1").Cells(i + 1, 2).Value = ""
        
        i = i + 1
        no_c = no_c + 1
        
    Loop
    i = 1
     no_d = 0
    Do Until Worksheets("MPS TEMPLATE").Cells(i + 6, 1).Value & Worksheets("MPS TEMPLATE").Cells(i + 6, 2).Value = ""
        
        i = i + 1
        no_d = no_d + 1
        
    Loop
ReDim pro2(1 To no_d)
ReDim cap2(1 To no_d)
ReDim Fmonth(1 To no_c)
ReDim commit(1 To no_c)
i = 1
    For i = 1 To no_d ' collection with array sheet : mps template
       pro2(i) = Worksheets("MPS TEMPLATE").Cells(6 + i, 1).Value
       cap2(i) = Worksheets("MPS TEMPLATE").Cells(6 + i, 2).Value
Next i
i = 1
    For i = 1 To no_c
      
       pro = Worksheets("summary1").Cells(i + 1, 1).Value
       cap = Worksheets("summary1").Cells(i + 1, 2).Value
       Fmonth(i) = Worksheets("summary1").Cells(i + 1, 3).Value
       commit(i) = Worksheets("summary1").Cells(i + 1, 5).Value
      
      ActiveWorkbook.Sheets("MPS TEMPLATE").Activate
   j = 1
  For j = 1 To no_d  'check month and procap
  
     If (Fmonth(i) = Worksheets("MPS TEMPLATE").Cells(6, 3).Value) And (pro = pro2(j)) And (cap = cap2(j)) Then
        Worksheets("MPS TEMPLATE").Cells(6 + j, 3).Value = commit(i)
        
        x = 1
        Exit For
   Else
     x = 0
     
     End If
    Next j
    Next i
    
    sum = 0
    total = 0
      For j = 1 To no_d  'sum commit sub total
      If pro2(j) <> "Sub Total" Then
        sum = sum + Worksheets("MPS TEMPLATE").Cells(6 + j, 3).Value
       sum = sum + Worksheets("MPS TEMPLATE").Cells(6 + j, 6).Value
      ElseIf pro2(j) = "Sub Total" Then
        Worksheets("MPS TEMPLATE").Cells(6 + j, 3).Value = sum
        total = total + sum
        sum = 0
        End If
        If j = no_d Then 'When complete cycle will be positive sub total = total
         Worksheets("MPS TEMPLATE").Cells(6 + j, 3).Value = total
        End If
    Next j

  j = 1
  For j = 1 To no_d
  If Worksheets("MPS TEMPLATE").Cells(6 + j, 3).Value = "" Then
    Worksheets("MPS TEMPLATE").Cells(6 + j, 3).Value = 0
    End If
   Next j
  
End Function