Macro to find the sum of shares against each name

Try this... (macro workbook attached, run update sub)

Sub Update()
    
    Dim WB_Report As Workbook
    Dim WS1 As Worksheet
    Dim WS2 As Worksheet
    Dim WS3 As Worksheet
    
    'Change to set reference to workbook/sheets
    Set WB_Report = Workbooks("Over share.xlsm")
    Set WS1 = WB_Report.Sheets("Data")
    Set WS2 = WB_Report.Sheets("Share above 100")
    Set WS3 = WB_Report.Sheets("Share below 100")
    
    Dim bFound As Boolean
    
    Application.DisplayAlerts = False
    
    If LastRow(1, WS2.Name, WB_Report.Name) > 1 Then WS2.Rows("2:" & LastRow(1, WS2.Name, WB_Report.Name)).Delete
    
    If LastRow(1, WS3.Name, WB_Report.Name) > 1 Then WS3.Rows("2:" & LastRow(1, WS3.Name, WB_Report.Name)).Delete
    
    For x = 2 To LastRow(1, WS1.Name, WB_Report.Name)
        
        If WS1.Cells(x, 4).Value > 100 Then
                
            bFound = False
                
            For y = 2 To LastRow(1, WS2.Name, WB_Report.Name)
            
                If WS2.Cells(y, 1).Value Like WS1.Cells(x, 1).Value Then bFound = True
            
            Next y
            
            If bFound = False Then WS1.Rows(x).Copy Destination:=WS2.Rows(LastRow(1, WS2.Name, WB_Report.Name) + 1)
        
        End If
        
        If WS1.Cells(x, 4).Value < 100 Then
        
            bFound = False
                
            For y = 2 To LastRow(1, WS3.Name, WB_Report.Name)
            
                If WS3.Cells(y, 1).Value Like WS3.Cells(x, 1).Value Then bFound = True
            
            Next y
            
            If bFound = False Then WS1.Rows(x).Copy Destination:=WS3.Rows(LastRow(1, WS3.Name, WB_Report.Name) + 1)
        
        End If
    
    Next x
    
    WS2.Columns.AutoFit
    WS3.Columns.AutoFit
    
    Application.DisplayAlerts = True
    
End Sub

Function LastRow(nColumn As Integer, Optional sSheet As String, Optional sWorkbook As String)

On Error GoTo ErrHandler

    Dim WS As Worksheet
    Dim WB As Workbook
    
    If (sWorkbook = "") Then
        Set WB = ActiveWorkbook
    Else
        Set WB = Workbooks(sWorkbook)
    End If
    
    If (sSheet = "") Then
        Set WS = WB.ActiveSheet
    Else
        Set WS = WB.Sheets(sSheet)
    End If
    
    If WS.Cells(1, nColumn).Value = "" Then
    
        LastRow = 0
        
    Else
    
        LastRow = WS.Cells(Rows.Count, nColumn).End(xlUp).Row
        
    End If
    
ErrHandler:
    
    If Err <> 0 Then LastRow = ""

    Exit Function

End Function

Hi,

Thanks for replying.
This is not working in the way that I was expecting.. let me explain in detail.

I want the people whose sum of shares more than 100 to be placed in sheet “share above 100”. As per the attached sample, Arun’s share is 135 (sum of shares across all projects) and similarly Arjun’s share is 315. Since both of these people have more than 100, these 2 names alone have to be placed in sheet “share above 100”.


In the same way Patric’s share is 60 (sum of shares across all projects) and similarly Vimal’s share is 1. Since both of these people have less than 100, these 2 names alone have to be placed in sheet “share below 100"

I have pasted the details that has to come in the sheets “above 100 shares” and “less than 100 shares.. I am looking for the same details after applying the codes.

Please help me..

Hi Team, Please help

Originally Posted by jaslake

Hi arun.sj

What it it's equal to 100 (David)?

Hi John, if the sum of shares is equal to 100, it should be ignored.. Only above 100 shares and less than 100 have to be pasted to the respective sheets..

Originally Posted by jaslake

Hi arun.sj

What it it's equal to 100 (David)?

Hi John, if the sum of shares is equal to 100, it should be ignored.. Only above 100 shares and less than 100 have to be pasted to the respective sheets..

You want to exclude the 100 shares in total....

Sub test()
    Dim a, i As Long, ii As Long, w, e
    Dim Above100(), Below100(), n As Long, t As Long
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    a = Application.Index(a, Evaluate("row(1:" & _
        UBound(a, 1) & ")"), [{2,3,4,6,7,8}])
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2))
                For ii = 1 To UBound(a, 2)
                    w(ii) = a(i, ii)
                Next
                .Item(a(i, 1)) = w
            Else
                w = .Item(a(i, 1))
                w(3) = w(3) + a(i, 3)
                .Item(a(i, 1)) = w
            End If
        Next
        For Each e In .keys
            If .Item(e)(3) > 100 Then
                n = n + 1: ReDim Preserve Above100(1 To n)
                Above100(n) = .Item(e)
            ElseIf .Item(e)(3) < 100 Then
                t = t + 1: ReDim Preserve Below100(1 To t)
                Below100(t) = .Item(e)
            End If
        Next
    End With
    OutPut "Share above 100", n, Above100, a
    OutPut "Share below 100", t, Below100, a
End Sub

Private Sub OutPut(wsName As String, n As Long, x, a)
    With Sheets(wsName).Cells(1).Resize(, UBound(a, 2))
        With .CurrentRegion
            .ClearContents
            .Borders.LineStyle = xlNone
        End With
        .Value = a
        If n > 0 Then
            .Rows(2).Resize(n).Value = Application.Index(x, 0, 0)
            .CurrentRegion.Borders.Weight = 3
        End If
    End With
End Sub

Originally Posted by jindon

You want to exclude the 100 shares in total....

Sub test()
    Dim a, i As Long, ii As Long, w, e
    Dim Above100(), Below100(), n As Long, t As Long
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    a = Application.Index(a, Evaluate("row(1:" & _
        UBound(a, 1) & ")"), [{2,3,4,6,7,8}])
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2))
                For ii = 1 To UBound(a, 2)
                    w(ii) = a(i, ii)
                Next
                .Item(a(i, 1)) = w
            Else
                w = .Item(a(i, 1))
                w(3) = w(3) + a(i, 3)
                .Item(a(i, 1)) = w
            End If
        Next
        For Each e In .keys
            If .Item(e)(3) > 100 Then
                n = n + 1: ReDim Preserve Above100(1 To n)
                Above100(n) = .Item(e)
            ElseIf .Item(e)(3) < 100 Then
                t = t + 1: ReDim Preserve Below100(1 To t)
                Below100(t) = .Item(e)
            End If
        Next
    End With
    OutPut "Share above 100", n, Above100, a
    OutPut "Share below 100", t, Below100, a
End Sub

Private Sub OutPut(wsName As String, n As Long, x, a)
    With Sheets(wsName).Cells(1).Resize(, UBound(a, 2))
        With .CurrentRegion
            .ClearContents
            .Borders.LineStyle = xlNone
        End With
        .Value = a
        If n > 0 Then
            .Rows(2).Resize(n).Value = Application.Index(x, 0, 0)
            .CurrentRegion.Borders.Weight = 3
        End If
    End With
End Sub

Thanks for replying.. I am getting syntax error..

Can you help me by updating the codes in the sample attached please.

Originally Posted by jindon

You want to exclude the 100 shares in total....

Sub test()
    Dim a, i As Long, ii As Long, w, e
    Dim Above100(), Below100(), n As Long, t As Long
    a = Sheets("sheet1").Cells(1).CurrentRegion.Value
    a = Application.Index(a, Evaluate("row(1:" & _
        UBound(a, 1) & ")"), [{2,3,4,6,7,8}])
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2))
                For ii = 1 To UBound(a, 2)
                    w(ii) = a(i, ii)
                Next
                .Item(a(i, 1)) = w
            Else
                w = .Item(a(i, 1))
                w(3) = w(3) + a(i, 3)
                .Item(a(i, 1)) = w
            End If
        Next
        For Each e In .keys
            If .Item(e)(3) > 100 Then
                n = n + 1: ReDim Preserve Above100(1 To n)
                Above100(n) = .Item(e)
            ElseIf .Item(e)(3) < 100 Then
                t = t + 1: ReDim Preserve Below100(1 To t)
                Below100(t) = .Item(e)
            End If
        Next
    End With
    OutPut "Share above 100", n, Above100, a
    OutPut "Share below 100", t, Below100, a
End Sub

Private Sub OutPut(wsName As String, n As Long, x, a)
    With Sheets(wsName).Cells(1).Resize(, UBound(a, 2))
        With .CurrentRegion
            .ClearContents
            .Borders.LineStyle = xlNone
        End With
        .Value = a
        If n > 0 Then
            .Rows(2).Resize(n).Value = Application.Index(x, 0, 0)
            .CurrentRegion.Borders.Weight = 3
        End If
    End With
End Sub

Thanks for replying.. I am getting syntax error..

Can you help me by updating the codes in the sample attached please.

Originally Posted by PCI

For the fun another one
Note:
in sheet "Share below 100" is included total share =100
if you want the opposite change
"If (ObjDic1.Item(K) > 100) Then" to "If (ObjDic1.Item(K) >= 100) Then"

Option Explicit

Sub Treat()
Dim WkRg  As Range
Dim F  As Range
Dim ObjDic1   As Object, ObjDic2   As Object
Set ObjDic1 = CreateObject("Scripting.Dictionary")
Set ObjDic2 = CreateObject("Scripting.Dictionary")
Dim K
Dim II  As Long, III  As Long
Dim Temp
    Set WkRg = Sheets("Sheet1").Cells(1, 1).CurrentRegion.Columns(2).Offset(1, 0).Cells

    For Each F In WkRg
        With ObjDic1
            If (.exists(F.Value)) Then
                 .Item(F.Value) = .Item(F.Value) + F.Offset(0, 2).Value
            Else
                .Item(F.Value) = F.Offset(0, 2).Value
            End If
        End With
        With ObjDic2
            .Item(F.Value) = Array(F, F.Offset(0, 1), F.Offset(0, 2) _
                                   , F.Offset(0, 4), F.Offset(0, 5), F.Offset(0, 6))
        End With
    Next F
    Sheets("Share above 100").Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
    Sheets("Share below 100").Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
    II = 1: III = 1
    For Each K In ObjDic1
        Temp = ObjDic2.Item(K)
        If (ObjDic1.Item(K) > 100) Then
            II = II + 1
            With Sheets("Share above 100")
                .Cells(II, 1).Resize(1, 6) = Temp
                .Cells(II, 3) = ObjDic1.Item(K)
            End With
        Else
            III = III + 1
            With Sheets("Share below 100")
                .Cells(III, 1).Resize(1, 6) = Temp
                .Cells(III, 3) = ObjDic1.Item(K)
            End With
        End If
    Next
End Sub

This is working..
The only thing is share equal to 100 should be completely ignored which is not happening..
Only share above 100 and below 100 should be available in the respective sheets..

Please help..

Syntax error??

Originally Posted by jindon

Syntax error??

This is working perfectly fine..
I need your help to understand this code so I can make necessary changes when I use this in different files..

Can you please help me by adding a comment beside the code so that I will be able to make changes.. Please help..

Maybe:

Sub arun_sj()
Dim i As Long
For i = Range("C" & Rows.Count).End(3).row To 1 Step -1
    If Cells(i, "C") <> Cells(i + 1, "C") Then Rows(i + 1).Insert
Next i
For Each numrange In Columns("D").SpecialCells(xlConstants, xlNumbers).Areas
        sumaddr = numrange.Address(False, False)
        numrange.Offset(numrange.Count, 0).Resize(1, 1).Formula = "=SUM(" & sumaddr & ")"
        Select Case numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
            Case Is > 100
                Cells(numrange.row, "B").Copy Sheets("Share above 100").Range("A" & Rows.Count).End(3)(2)
                Cells(numrange.row, "C").Copy Sheets("Share above 100").Range("B" & Rows.Count).End(3)(2)
                Sheets("Share above 100").Range("C" & Rows.Count).End(3)(2).Value = numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
                Cells(numrange.row, "F").Copy Sheets("Share above 100").Range("D" & Rows.Count).End(3)(2)
                Cells(numrange.row, "G").Copy Sheets("Share above 100").Range("E" & Rows.Count).End(3)(2)
                Cells(numrange.row, "H").Copy Sheets("Share above 100").Range("F" & Rows.Count).End(3)(2)
            Case Is < 100
                Cells(numrange.row, "B").Copy Sheets("Share Below 100").Range("A" & Rows.Count).End(3)(2)
                Cells(numrange.row, "C").Copy Sheets("Share Below 100").Range("B" & Rows.Count).End(3)(2)
                Sheets("Share Below 100").Range("C" & Rows.Count).End(3)(2).Value = numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
                Cells(numrange.row, "F").Copy Sheets("Share Below 100").Range("D" & Rows.Count).End(3)(2)
                Cells(numrange.row, "G").Copy Sheets("Share Below 100").Range("E" & Rows.Count).End(3)(2)
                Cells(numrange.row, "H").Copy Sheets("Share Below 100").Range("F" & Rows.Count).End(3)(2)
        End Select
Next numrange
Range("A2:A" & Range("A" & Rows.Count).End(3).row).SpecialCells(4).EntireRow.Delete
End Sub

Originally Posted by JOHN H. DAVIS

Maybe:

Sub arun_sj()
Dim i As Long
For i = Range("C" & Rows.Count).End(3).row To 1 Step -1
    If Cells(i, "C") <> Cells(i + 1, "C") Then Rows(i + 1).Insert
Next i
For Each numrange In Columns("D").SpecialCells(xlConstants, xlNumbers).Areas
        sumaddr = numrange.Address(False, False)
        numrange.Offset(numrange.Count, 0).Resize(1, 1).Formula = "=SUM(" & sumaddr & ")"
        Select Case numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
            Case Is > 100
                Cells(numrange.row, "B").Copy Sheets("Share above 100").Range("A" & Rows.Count).End(3)(2)
                Cells(numrange.row, "C").Copy Sheets("Share above 100").Range("B" & Rows.Count).End(3)(2)
                Sheets("Share above 100").Range("C" & Rows.Count).End(3)(2).Value = numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
                Cells(numrange.row, "F").Copy Sheets("Share above 100").Range("D" & Rows.Count).End(3)(2)
                Cells(numrange.row, "G").Copy Sheets("Share above 100").Range("E" & Rows.Count).End(3)(2)
                Cells(numrange.row, "H").Copy Sheets("Share above 100").Range("F" & Rows.Count).End(3)(2)
            Case Is < 100
                Cells(numrange.row, "B").Copy Sheets("Share Below 100").Range("A" & Rows.Count).End(3)(2)
                Cells(numrange.row, "C").Copy Sheets("Share Below 100").Range("B" & Rows.Count).End(3)(2)
                Sheets("Share Below 100").Range("C" & Rows.Count).End(3)(2).Value = numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
                Cells(numrange.row, "F").Copy Sheets("Share Below 100").Range("D" & Rows.Count).End(3)(2)
                Cells(numrange.row, "G").Copy Sheets("Share Below 100").Range("E" & Rows.Count).End(3)(2)
                Cells(numrange.row, "H").Copy Sheets("Share Below 100").Range("F" & Rows.Count).End(3)(2)
        End Select
Next numrange
Range("A2:A" & Range("A" & Rows.Count).End(3).row).SpecialCells(4).EntireRow.Delete
End Sub

This is working but have few minor issues.. After applying the codes, few cells are colored as in the heading in the sheet "share above 100"..

Originally Posted by PCI

"share equal to 100 should be completely ignored " Yes it was prepared like that
So use next code

Option Explicit

Sub Treat()
Dim WkRg  As Range
Dim F  As Range
Dim ObjDic1   As Object, ObjDic2   As Object
Set ObjDic1 = CreateObject("Scripting.Dictionary")
Set ObjDic2 = CreateObject("Scripting.Dictionary")
Dim K
Dim II  As Long, III  As Long
Dim Temp
    Set WkRg = Sheets("Sheet1").Cells(1, 1).CurrentRegion.Columns(2).Offset(1, 0).Cells

    For Each F In WkRg
        With ObjDic1
            If (.exists(F.Value)) Then
                 .Item(F.Value) = .Item(F.Value) + F.Offset(0, 2).Value
            Else
                .Item(F.Value) = F.Offset(0, 2).Value
            End If
        End With
        With ObjDic2
            .Item(F.Value) = Array(F, F.Offset(0, 1), F.Offset(0, 2) _
                                   , F.Offset(0, 4), F.Offset(0, 5), F.Offset(0, 6))
        End With
    Next F
    Sheets("Share above 100").Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
    Sheets("Share below 100").Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
    II = 1: III = 1
    For Each K In ObjDic1
        Temp = ObjDic2.Item(K)
        If (ObjDic1.Item(K) > 100) Then
            II = II + 1
            With Sheets("Share above 100")
                .Cells(II, 1).Resize(1, 6) = Temp
                .Cells(II, 3) = ObjDic1.Item(K)
            End With
        ElseIf (ObjDic1.Item(K) < 100) Then
            III = III + 1
            With Sheets("Share below 100")
                .Cells(III, 1).Resize(1, 6) = Temp
                .Cells(III, 3) = ObjDic1.Item(K)
            End With
        End If
    Next
End Sub

Thanks for replying .. unfortunately i am getting a "run-time error 9 :Subscript out of range" ..

If you can update the codes in the sample file, it would be of great help.. Please help..

Originally Posted by PCI

The macro run OK with the sample you sent
See attached

This is working perfectly fine... .. Thank you so much for your help..

need your help to understand the code.. requesting you to please explain me the codes so i can make changes while using it in diff files... Please help..

I tested with your sample data and didn't have any issues. However, try this.

Sub arun_sj()
Dim i As Long
For i = Range("C" & Rows.Count).End(3).row To 1 Step -1
    If Cells(i, "C") <> Cells(i + 1, "C") Then Rows(i + 1).Insert
Next i
For Each numrange In Columns("D").SpecialCells(xlConstants, xlNumbers).Areas
        sumaddr = numrange.Address(False, False)
        numrange.Offset(numrange.Count, 0).Resize(1, 1).Formula = "=SUM(" & sumaddr & ")"
        Select Case numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
            Case Is > 100
                Cells(numrange.row, "B").Copy Sheets("Share above 100").Range("A" & Rows.Count).End(3)(2)
                Cells(numrange.row, "C").Copy Sheets("Share above 100").Range("B" & Rows.Count).End(3)(2)
                Sheets("Share above 100").Range("C" & Rows.Count).End(3)(2).Value = numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
                Cells(numrange.row, "F").Copy Sheets("Share above 100").Range("D" & Rows.Count).End(3)(2)
                Cells(numrange.row, "G").Copy Sheets("Share above 100").Range("E" & Rows.Count).End(3)(2)
                Cells(numrange.row, "H").Copy Sheets("Share above 100").Range("F" & Rows.Count).End(3)(2)
                Sheets("Share above 100").Rows(Range("A" & Rows.Count).End(3).row).Interior.ColorIndex = xlNone
            Case Is < 100
                Cells(numrange.row, "B").Copy Sheets("Share Below 100").Range("A" & Rows.Count).End(3)(2)
                Cells(numrange.row, "C").Copy Sheets("Share Below 100").Range("B" & Rows.Count).End(3)(2)
                Sheets("Share Below 100").Range("C" & Rows.Count).End(3)(2).Value = numrange.Offset(numrange.Count, 0).Resize(1, 1).Value
                Cells(numrange.row, "F").Copy Sheets("Share Below 100").Range("D" & Rows.Count).End(3)(2)
                Cells(numrange.row, "G").Copy Sheets("Share Below 100").Range("E" & Rows.Count).End(3)(2)
                Cells(numrange.row, "H").Copy Sheets("Share Below 100").Range("F" & Rows.Count).End(3)(2)
                Sheets("Share Below 100").Rows(Range("A" & Rows.Count).End(3).row).Interior.ColorIndex = xlNone
        End Select
Next numrange
Range("A2:A" & Range("A" & Rows.Count).End(3).row).SpecialCells(4).EntireRow.Delete
End Sub

You probably nedd to change

    a = Application.Index(a, Evaluate("row(1:" & _
        UBound(a, 1) & ")"), [{2,3,4,6,7,8}])

This creates the data set only columns that is necessary to work with, also match up with the column order to output heading.
i.e

ID	Name	Share	Grade	Location	Supervisor Name
2	3	4	6	7	8

If you place Column "ID" in 1, "Share" in 3, no need to change the rest.

Originally Posted by jindon

You probably nedd to change

    a = Application.Index(a, Evaluate("row(1:" & _
        UBound(a, 1) & ")"), [{2,3,4,6,7,8}])

This creates the data set only columns that is necessary to work with, also match up with the column order to output heading.
i.e

ID	Name	Share	Grade	Location	Supervisor Name
2	3	4	6	7	8

If you place Column "ID" in 1, "Share" in 3, no need to change the rest.

Thanks for your reply.. Sorry but i need a bit more detailed since i am not that good with the codes..

i understood the part [{2,3,4,6,7,8}]).. but when i tried with a diff sample by updating this part, the columns are placed correctly as expected but the details were incorrect .. like shares with below 100 values are also placed in sheet "Share above 100"..

Please help..

Upload your original file with dummy data, but data layouts must be correct order.

Originally Posted by jindon

Upload your original file with dummy data, but data layouts must be correct order.

Thank you so much for asking the original format.. Attached is the original file with sample data.. I have highlighted the columns that has to be brought to the sheets "Share above 100" and "Share below 100".

The column which has the share value is column AN..

Please help..

Originally Posted by PCI

"need your help to understand the code"
The code is very simple but you need first to understand how "Scripting.Dictionary" is working.
There is 2 Dictionaries:
- One to make the list of the ID and the sum of the share
- One to make the list of the ID and the information attached to the ID
A first part of the macro is preparing the Dictionary
A second part of the macro is doing the display versus the sum of the share recorded in the first dictionary
From first dictionary, depending of the sum, the corresponding ID is used to search in the second dictionary the corresponding information and display it.

Thanks a lot for explaining .. But sorry to bother you , i was trying to use this code to my original dump however i am getting error ..

If you can help me by updating the codes in the attached file , i no more have to worry and it would be of great help.. Requesting for your help..

I have highlighted the columns that has to be considered. The column which has the share value is column AN..

Please help..

And now for something completely different...

over_share_cy.xlsm

Public Sub Clear_Click()
    ThisWorkbook.Worksheets("Share above 100").Cells.ClearContents
    ThisWorkbook.Worksheets("Share below 100").Cells.ClearContents
End Sub

Public Sub Run_Click()
    Dim XDB As ExcelDataEngine
    Dim Sql As String
    Dim Rows As Long
    
    'create instance of data access class
    Set XDB = New ExcelDataEngine
    
    'transfer shares above 100
    Sql = "SELECT ID, Name, SUM(Share) AS Share, Grade, Location, [Supervisor Name]" & vbCrLf & _
          " FROM {Shares_Table} AS Shares" & vbCrLf & _
          " GROUP BY ID, Name, Grade, Location, [Supervisor Name]" & vbCrLf & _
          " HAVING SUM(Share)>100"
    ThisWorkbook.Worksheets("Share above 100").Cells.ClearContents
    'transfer results of query to worksheet
    Rows = XDB.PutQueryData(Sql, ThisWorkbook.Worksheets("Share above 100").Range("A1"))
    
    'transfer shares below 100
    Sql = "SELECT ID, Name, SUM(Share) AS Share, Grade, Location, [Supervisor Name]" & vbCrLf & _
          " FROM {Shares_Table} AS Shares" & vbCrLf & _
          " GROUP BY ID, Name, Grade, Location, [Supervisor Name]" & vbCrLf & _
          " HAVING SUM(Share)<100"
    ThisWorkbook.Worksheets("Share below 100").Cells.ClearContents
    'transfer results of query to worksheet
    Rows = XDB.PutQueryData(Sql, ThisWorkbook.Worksheets("Share below 100").Range("A1"))
    
End Sub

    a = Application.Index(a, Evaluate("row(1:" & _
        UBound(a, 1) & ")"), [{2,4,40,5,13,14,15,16}])

Originally Posted by jindon

    a = Application.Index(a, Evaluate("row(1:" & _
        UBound(a, 1) & ")"), [{2,4,40,5,13,14,15,16}])

Thanks a Million Jindon This is working perfectly fine..

Originally Posted by arun.sj

Thanks a Million Jindon This is working perfectly fine..

You are welcome and thanks for multiple reps.

Originally Posted by PCI

No big difference

Option Explicit

Sub Treat()
Dim WkRg  As Range
Dim F  As Range
Dim ObjDic1   As Object, ObjDic2   As Object
Set ObjDic1 = CreateObject("Scripting.Dictionary")
Set ObjDic2 = CreateObject("Scripting.Dictionary")
Dim K
Dim II  As Long, III  As Long
Dim Temp
    Set WkRg = Sheets("Sheet1").Cells(1, 1).CurrentRegion.Columns(2).Offset(1, 0).Cells  '   Column "B" - 2 = Assosiate ID

    For Each F In WkRg
        With ObjDic1
            If (.exists(F.Value)) Then
                 .Item(F.Value) = .Item(F.Value) + F.Offset(0, 38).Value
            Else
                .Item(F.Value) = F.Offset(0, 38).Value              '   Column "AN"  = Share
            End If
        End With
        With ObjDic2
'         Column "D" = Associate Name       Offset  2
'         Column "E" = Grade                Offset  3
'         Column "M" = Project ID           Offset  11
'         Column "N" = Project Name         Offset  12
'         Column "O" = Project Manager      Offset  13
'         Column "P" = Manager Name         Offset  14

            .Item(F.Value) = Array(F, F.Offset(0, 2), F.Offset(0, 3) _
                                   , F.Offset(0, 11), F.Offset(0, 12), F.Offset(0, 13), F.Offset(0, 14))
        End With
    Next F
    Sheets("Share above 100").Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
    Sheets("Share below 100").Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
    II = 1: III = 1
    For Each K In ObjDic1
        Temp = ObjDic2.Item(K)
        If (ObjDic1.Item(K) > 100) Then
            II = II + 1
            With Sheets("Share above 100")
                .Cells(II, 1).Resize(1, 7) = Temp
                .Cells(II, 8) = ObjDic1.Item(K)
            End With
        ElseIf (ObjDic1.Item(K) < 100) Then
            III = III + 1
            With Sheets("Share below 100")
                .Cells(III, 1).Resize(1, 7) = Temp
                .Cells(III, 8) = ObjDic1.Item(K)
            End With
        End If
    Next
End Sub

Hi PCI .. Thanks for explaining in detail in this code..
i need one more help before closing the thread.. After the data is pasted in both the sheets, it would be good if there is border across the data in both the sheets.. border in all the cells with black or blue color..

Requesting for your help to update the above code..

Originally Posted by PCI

A remake
( Thx Jindon )

Option Explicit

Sub Treat1()
Dim WkRg  As Range
Dim WkTb
Dim F
Dim ObjDic1   As Object, ObjDic2   As Object
Set ObjDic1 = CreateObject("Scripting.Dictionary")
Set ObjDic2 = CreateObject("Scripting.Dictionary")
Dim K
Dim I  As Long, II As Long, III  As Long
Dim Temp
  
    WkTb = Sheets("Data").Cells(1, 1).CurrentRegion.Offset(1, 0).Value
    WkTb = Application.Index(WkTb, Evaluate("row(1:" & UBound(WkTb, 1) & ")"), Split("2,4,5,13,14,15,16,40", ","))
    
    For I = 1 To UBound(WkTb, 1)
        With ObjDic1
            If (.exists(WkTb(I, 1))) Then
                 .Item(WkTb(I, 1)) = .Item(WkTb(I, 1)) + WkTb(I, 8)
            Else
                .Item(WkTb(I, 1)) = WkTb(I, 8)
            End If
        End With
        With ObjDic2
            .Item(WkTb(I, 1)) = Array(WkTb(I, 1), WkTb(I, 2), WkTb(I, 3), WkTb(I, 4) _
                                    , WkTb(I, 5), WkTb(I, 6), WkTb(I, 7), WkTb(I, 8))
        End With
    Next I
    
    Sheets("Share above 100").Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
    Sheets("Share below 100").Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
    II = 1: III = 1
    For Each K In ObjDic1
        Temp = ObjDic2.Item(K)
        If (ObjDic1.Item(K) > 100) Then
            II = II + 1
            With Sheets("Share above 100")
                .Cells(II, 1).Resize(1, 8) = Temp
                .Cells(II, 8) = ObjDic1.Item(K)
            End With
        Else
            If (ObjDic1.Item(K) < 100) Then
                III = III + 1
                With Sheets("Share below 100")
                    .Cells(III, 1).Resize(1, 8) = Temp
                    .Cells(III, 8) = ObjDic1.Item(K)
                End With
            End If
        End If
    Next
End Sub

Thanks a lot for replying .. i am getting error that says "subscript out of range" for this code...

but the code in your previous post : -

  Option Explicit

Sub Treat()
Dim WkRg  As Range
Dim F  As Range
Dim ObjDic1   As Object, ObjDic2   As Object
Set ObjDic1 = CreateObject("Scripting.Dictionary")
Set ObjDic2 = CreateObject("Scripting.Dictionary")
Dim K
Dim II  As Long, III  As Long
Dim Temp
    Set WkRg = Sheets("Sheet1").Cells(1, 1).CurrentRegion.Columns(2).Offset(1, 0).Cells  '   Column "B" - 2 = Assosiate ID

    For Each F In WkRg
        With ObjDic1
            If (.exists(F.Value)) Then
                 .Item(F.Value) = .Item(F.Value) + F.Offset(0, 38).Value
            Else
                .Item(F.Value) = F.Offset(0, 38).Value              '   Column "AN"  = Share
            End If
        End With
        With ObjDic2
'         Column "D" = Associate Name       Offset  2

This code is working perfectly fine.. shall i consider this code ? do you think there should be any updates? please help

Originally Posted by PCI

"do you think there should be any updates? "
No keep the first one, it is a technical more VBA improvement with no effect on the result.
But can you give me more details where it stops and beter send the file for test.

Sure.. Attaching the file.. Requesting you to check..

Originally Posted by PCI

Is it what you want !

Option Explicit

Sub Treat()
Dim WkRg  As Range
Dim F  As Range
Dim ObjDic1   As Object, ObjDic2   As Object
Set ObjDic1 = CreateObject("Scripting.Dictionary")
Set ObjDic2 = CreateObject("Scripting.Dictionary")
Dim K
Dim II  As Long, III  As Long
Dim Temp
    Set WkRg = Sheets("Sheet1").Cells(1, 1).CurrentRegion.Columns(2).Offset(1, 0).Cells  '   Column "B" - 2 = Assosiate ID

    For Each F In WkRg
        With ObjDic1
            If (.exists(F.Value)) Then
                 .Item(F.Value) = .Item(F.Value) + F.Offset(0, 38).Value
            Else
                .Item(F.Value) = F.Offset(0, 38).Value              '   Column "AN"  = Share
            End If
        End With
        With ObjDic2
'         Column "D" = Associate Name       Offset  2
'         Column "E" = Grade                Offset  3
'         Column "M" = Project ID           Offset  11
'         Column "N" = Project Name         Offset  12
'         Column "O" = Project Manager      Offset  13
'         Column "P" = Manager Name         Offset  14

            .Item(F.Value) = Array(F, F.Offset(0, 2), F.Offset(0, 3) _
                                   , F.Offset(0, 11), F.Offset(0, 12), F.Offset(0, 13), F.Offset(0, 14))
        End With
    Next F
    
'   Results Sheets   Preparation
    Sheets("Share above 100").Cells(1, 1).CurrentRegion.Offset(1, 0).Delete Shift:=xlUp
    Sheets("Share below 100").Cells(1, 1).CurrentRegion.Offset(1, 0).Delete Shift:=xlUp
'   Results Sheets   Update  data
    II = 1: III = 1
    For Each K In ObjDic1
        Temp = ObjDic2.Item(K)
        If (ObjDic1.Item(K) > 100) Then
            II = II + 1
            With Sheets("Share above 100")
                .Cells(II, 1).Resize(1, 7) = Temp
                .Cells(II, 8) = ObjDic1.Item(K)
            End With
        ElseIf (ObjDic1.Item(K) < 100) Then
            III = III + 1
            With Sheets("Share below 100")
                .Cells(III, 1).Resize(1, 7) = Temp
                .Cells(III, 8) = ObjDic1.Item(K)
            End With
        End If
    Next
'   Results Sheets   Update  Format
    Sheets("Share above 100").Cells(1, 1).CurrentRegion.Offset(1, 0).Borders.ThemeColor = 8
    Sheets("Share below 100").Cells(1, 1).CurrentRegion.Offset(1, 0).Borders.ThemeColor = 8
  
End Sub

Yes.. That was exactly what i was looking for.. Thanks a Ton for the help.. The codes are working fantastic...