Consolidating data from multiple lines of a sheet (Excel 2007)

[elflapo]

Hi there, hope someone can help me with this query. (Apologies if this is not the standard way for submitting but it’s my first go). I’ve seen some examples here and I think I understand the consolidation function. However, my query has the added level of needing to consolidate each member:</SPAN></SPAN>
I have a table of data that looks like this:</SPAN></SPAN>

SURNAME</SPAN></SPAN>	NINO</SPAN></SPAN>	CODE</SPAN></SPAN>	NO OF UNITS</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	8AIA</SPAN></SPAN>	1986.4805</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	8AIA</SPAN></SPAN>	291.9253</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	HEEINC</SPAN></SPAN>	8137.0435</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	HEEINC</SPAN></SPAN>	1607.9067</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	IQSBI</SPAN></SPAN>	9999.7594</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	IQSBI</SPAN></SPAN>	1480.8712</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	MGCBSA</SPAN></SPAN>	14939.885</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	MGCBSA</SPAN></SPAN>	2195.5062</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	STAPGR</SPAN></SPAN>	488.1935</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	stapgr</SPAN></SPAN>	36.489</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	SZAAPA</SPAN></SPAN>	1860.91</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	SZAAPA</SPAN></SPAN>	139.09</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	SZGBA</SPAN></SPAN>	3721.82</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	SZGBA</SPAN></SPAN>	278.18</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	SZSUSA</SPAN></SPAN>	133.7666</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	szsusa</SPAN></SPAN>	9.9981</SPAN></SPAN>

<TBODY>
</TBODY>

There are a number of clients that have multiple investments that are shown by an alpha numeric code. I need to consolidate the number of units for each member in to one line. Ideally the output would look like this:</SPAN></SPAN>

SURNAME</SPAN></SPAN>	NINO</SPAN></SPAN>	CODE</SPAN></SPAN>	NO OF UNITS</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	8AIA</SPAN></SPAN>	2278.4058</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	HEEINC</SPAN></SPAN>	9744.9502</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	IQSBI</SPAN></SPAN>	11480.6306</SPAN></SPAN>
Smith</SPAN></SPAN>	AB123456C</SPAN></SPAN>	MGCBSA</SPAN></SPAN>	17135.3912</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	STAPGR</SPAN></SPAN>	524.6825</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	SZAAPA</SPAN></SPAN>	2000</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	SZGBA</SPAN></SPAN>	4000</SPAN></SPAN>
Jones</SPAN></SPAN>	XW123456Z</SPAN></SPAN>	SZSUSA</SPAN></SPAN>	143.7647</SPAN></SPAN>

<TBODY>
</TBODY>

Any help would be greatly appreciated as I am new to this and very stumped!!!!</SPAN></SPAN>
Regards</SPAN></SPAN>
Michael</SPAN></SPAN>

 

[elflapo]

Hello again, nothing had happened prior to the erro message. I've inserted the new code and all complies fine. When i run it the message box comes up but Sheet2 is blank.

 

[b.downey]

Is you original data in "Sheet1" Columns A-D?

 

[elflapo]

it is, sheet1 a to d with the headers and just the test data below it

 

[b.downey]

I have place a new MsgBox in the code... Please see if it is activate.

Option Explicit
Sub Process()
    Dim WsSrc As Worksheet
    Dim WsDst As Worksheet
    
    Dim SrcRowNo As Long
    Dim SrcLastRowNo As Long
    
    Dim DstRowNo As Long
    
    Dim CurrentKey As String
    Dim PreviousKey As String
    Dim RunningTotal As Double
    
    Set WsSrc = ThisWorkbook.Worksheets("Sheet1")
    Set WsDst = ThisWorkbook.Worksheets("Sheet2")
    
    SrcLastRowNo = WsSrc.Cells(WsSrc.Rows.Count, "A").End(xlUp).Row
    
    If SrcLastRowNo <= 2 Then
        MsgBox "Sheet '" & WsSrc.Name & "' only has " & SrcLastRowNo & " Rows of data in Column A", vbInformation, "Insufficent Data in Source Sheet"
        Exit Sub
    End If
    
    PreviousKey = GetKey(WsSrc, 2)
    RunningTotal = Val(WsSrc.Cells(2, "D"))
    For SrcRowNo = 3 To SrcLastRowNo
        CurrentKey = GetKey(WsSrc, SrcRowNo)
        If CurrentKey = PreviousKey Then
            RunningTotal = RunningTotal + Val(WsSrc.Cells(SrcRowNo, "D"))
        Else
            Call WriteRec(WsDst, DstRowNo, CurrentKey, RunningTotal)
            
            PreviousKey = CurrentKey
            RunningTotal = Val(WsSrc.Cells(SrcRowNo, "D"))
        End If
    Next SrcRowNo
    Call WriteRec(WsDst, DstRowNo, CurrentKey, RunningTotal)
    MsgBox "Complete", vbInformation
End Sub
Function GetKey(WsSrc As Worksheet, SrcRowNo As Long)
    GetKey = (Trim(WsSrc.Cells(SrcRowNo, "A"))) & "~" & UCase(Trim(WsSrc.Cells(SrcRowNo, "B"))) & "~" & UCase(Trim(WsSrc.Cells(SrcRowNo, "C")))
End Function
Function WriteRec(Ws As Worksheet, DstRowNo As Long, ByVal Key As String, ByVal RunningTotal As Double)
    Dim I As Integer
    Dim vkey As Variant
    
    vkey = Split(Key, "~")
    DstRowNo = DstRowNo + 1
    
    For I = 0 To UBound(vkey)
        Ws.Cells(DstRowNo, I + 1) = vkey(I)
    Next I
    Ws.Cells(DstRowNo, I + 1) = RunningTotal
End Function

 

[elflapo]

Hello, I’m getting a message box that says:

Insufficient data in Source Sheet1
Sheet’sheet1’ only has 1 rows of data in Column A.</SPAN>

 

[b.downey]

Ok... That is what I was hoping to see... (sort of)...

The Macro looks at column "A" on the worksheet tab call "Sheet1" (no spaces). If it does not find any data in that colum from Row 2 on, it will generate the message that you are now seeing. It also explains why you are getting the message (subscript out of bounds) you stated in your previous post.

Could you check the names of each of the tabs (worksheets) and make sure the Sample Data is in "Sheet1" (no spaces) and that it starts in cell A1 per your example.

I would request that if the following is verifed that you post the sample spreadsheet to Google Docs, Drop Box, or another site, so that I can see it directly

 

[elflapo]

Just for interest, if any. Original data on sheet1 starting at A1, results on Sheet2, starting at A1, (so ensure no data on Sheet2 before running code)

Sub amalg_lines()
Dim d As Object, c() As Variant
Dim a As Variant
Dim n As Long, i As Long, j As Long
Dim s As String

Set d = CreateObject("scripting.dictionary")
d.comparemode = 1
a = Range("A1").CurrentRegion.Resize(, 4)
n = UBound(a, 1)
ReDim c(1 To n, 1 To 4)

For i = 1 To n
    s = a(i, 1) & Chr(30) & a(i, 3)
    If d(s) = Empty Then
        d(s) = d.Count
        For j = 1 To 4
            c(d(s), j) = a(i, j)
        Next j
    Else
        c(d(s), 4) = c(d(s), 4) + a(i, 4)
    End If
Next i

Sheets("Sheet2").Resize(d.Count, 4) = c

End Sub

Hey Mirabeau cheers for posting. I tried your code but I get run-time error ‘438’ object doesn’t support this method or property.</SPAN>

 

[elflapo]

Ok... That is what I was hoping to see... (sort of)...

The Macro looks at column "A" on the worksheet tab call "Sheet1" (no spaces). If it does not find any data in that colum from Row 2 on, it will generate the message that you are now seeing. It also explains why you are getting the message (subscript out of bounds) you stated in your previous post.

Could you check the names of each of the tabs (worksheets) and make sure the Sample Data is in "Sheet1" (no spaces) and that it starts in cell A1 per your example.

I would request that if the following is verifed that you post the sample spreadsheet to Google Docs, Drop Box, or another site, so that I can see it directly

Good Morning B, i did have headers in a1,b1,c,1 and d1 that said Surname NINO CODE UNITS. I took these out and the code ran once!! (cheers) however, its not run again for some reason.

<TBODY>
</TBODY><COLGROUP><COL><COL><COL><COL></COLGROUP>

 

[mirabeau]

Hey Mirabeau cheers for posting. I tried your code but I get run-time error ‘438’ object doesn’t support this method or property.

It worked good for me when I tested it, using Windows 7, Excel 2007.

I guess you have a Mac. Microsoft cut back the VBA on those so there's some significant limitations.

Could easily do alternative approach, but you seem to be being well looked after.

 

[b.downey]

Are you using a MAC...

I have used the proceding code provided on a PC running and Excel 2007 and 2010. I not sure whe we are still having issues. I made some changes to the code. See if the attached code work on your machine

Option Explicit
Sub Process()
    Dim WsSrc As Worksheet
    Dim WsDst As Worksheet
    
    Dim SrcRowNo As Long
    Dim SrcLastRowNo As Long
    
    Dim DstRowNo As Long
    
    Dim CurrentKey As String
    Dim PreviousKey As String
    Dim RunningTotal As Double
    
    Set WsSrc = ThisWorkbook.Worksheets("Sheet1")
    Set WsDst = ThisWorkbook.Worksheets("Sheet2")
    
    SrcLastRowNo = WsSrc.Cells(WsSrc.Rows.Count, "A").End(xlUp).Row
    
    PreviousKey = GetKey(WsSrc, 2)
    RunningTotal = Val(WsSrc.Cells(2, "D"))
    SrcRowNo = 3
    Do While Len(Trim(WsSrc.Cells(SrcRowNo, "A"))) > 0
        CurrentKey = GetKey(WsSrc, SrcRowNo)
        If CurrentKey = PreviousKey Then
            RunningTotal = RunningTotal + Val(WsSrc.Cells(SrcRowNo, "D"))
        Else
            Call WriteRec(WsDst, DstRowNo, CurrentKey, RunningTotal)
            
            PreviousKey = CurrentKey
            RunningTotal = Val(WsSrc.Cells(SrcRowNo, "D"))
        End If
        SrcRowNo = SrcRowNo + 1
    Loop
    Call WriteRec(WsDst, DstRowNo, CurrentKey, RunningTotal)
    MsgBox "Complete", vbInformation
End Sub

Function GetKey(WsSrc As Worksheet, SrcRowNo As Long)
    GetKey = (Trim(WsSrc.Cells(SrcRowNo, "A"))) & "~" & UCase(Trim(WsSrc.Cells(SrcRowNo, "B"))) & "~" & UCase(Trim(WsSrc.Cells(SrcRowNo, "C")))
End Function
Function WriteRec(Ws As Worksheet, DstRowNo As Long, ByVal Key As String, ByVal RunningTotal As Double)
    Dim I As Integer
    Dim vkey As Variant
    
    vkey = Split(Key, "~")
    DstRowNo = DstRowNo + 1
    
    For I = 0 To UBound(vkey)
        Ws.Cells(DstRowNo, I + 1) = vkey(I)
    Next I
    Ws.Cells(DstRowNo, I + 1) = RunningTotal
End Function