Consolidating data

**newbi004** · 08-24-2012, 10:31 AM

Hi

I am using vba to list construction site information. This has created a list of items in a sheet called Site Survey.

This sheet has resulted in the following data:

Fence Section Type of Fence Type of Post Length No of Panels No of H Posts No of Corners
1 Wood Post and Panel Start WITH Post 15.6 9 9
1 Wood Post and Panel Corner - SINGLE Post 7.8 5 4 1
1 Wood Post and Panel Corner - SINGLE Post 7.4 4 3 1
2 Concrete Post and Panel Intermediate - SINGLE Post 6.7 4 5
2 Concrete Post and Panel Corner - DOUBLE Post 5.3 3 4 1
3 Post & Rail End WITH Post 6.2 6 7
3 Post & Rail Start WITH Post 15.6 9 10

I now want to consolidate this information into a sheet called "Site Data" which shows the total length of each Fence Section, adds the No of Panels, No of H Posts and No of Corners for each Fence Section. So the resulting information in the sheet "Site Data" should look like this:

Fence Section Type of Fence Total Length Total No of Panels Total No of H Posts Total No of Corners
1 Wood Post and Panel 30.8 18 16 2
2 Concrete Post and Panel 12.0 7 9 1
3 Post & Rail 21.8 15 17 0

Can anyone advise how I can do this using vba?

Thanks

---------- Post added at 03:31 PM ---------- Previous post was at 03:29 PM ----------

Gosh, the formatting has messed up in this! I don't know how to tab the data!!!

**mike7952** · 08-24-2012, 10:48 AM

Try attaching a workbook. With before and after results

To attach a file, push the button with the paperclip (or scroll down to the Manage Attachments button), browse to the required file, and then push the Upload button.

**newbi004** · 08-24-2012, 11:13 AM

Thanks for the advice, Mike.

I attach the sample workbook

**mike7952** · 08-24-2012, 11:54 AM

give this a try

Option Explicit
Sub aaa()
    Const shSurvey As String = "Site Survey"
    Const shData As String = "Site Data"
    Dim AllCells As Range, Cell As Range
    Dim UniqueValues As New Collection
    Dim i As Integer, j As Integer
    Dim Swap1, Swap2, Item
    Dim Lastrow As Long
    Dim a As Variant
    
    Worksheets(shSurvey).AutoFilterMode = False
'   Find lastrow on Column A
    Lastrow = Worksheets(shSurvey).Cells(Rows.CountLarge, 1).End(xlUp).Row
'   Get items are in Column A
    Set AllCells = Worksheets(shSurvey).Range("A3:A" & Lastrow)
'   The next statement ignores the error caused
'   by attempting to add a duplicate key to the collection.
'   The duplicate is not added - which is just what we want!
    On Error Resume Next
    For Each Cell In AllCells
        UniqueValues.Add Cell.Value, CStr(Cell.Value)
'       Note: the 2nd argument (key) for the Add method must be a string
    Next Cell

'   Resume normal error handling
    On Error GoTo 0

'   Sort the collection (optional)
    For i = 1 To UniqueValues.Count - 1
        For j = i + 1 To UniqueValues.Count
            If UniqueValues(i) > UniqueValues(j) Then
                Swap1 = UniqueValues(i)
                Swap2 = UniqueValues(j)
                UniqueValues.Add Swap1, before:=j
                UniqueValues.Add Swap2, before:=i
                UniqueValues.Remove i + 1
                UniqueValues.Remove j + 1
            End If
        Next j
    Next i
    i = 1
    ReDim a(1 To UniqueValues.Count, 1 To 6)
'   Now due something with the sorted non-duplicated items
    Application.ScreenUpdating = False
    For Each Item In UniqueValues
        With Worksheets(shSurvey)
            .Range("A2:A" & Lastrow).AutoFilter Field:=1, Criteria1:=Item
            Set AllCells = .Range("A3:G" & Lastrow).SpecialCells(xlCellTypeVisible)
            a(i, 1) = .Cells(AllCells.Row, 1)
            a(i, 2) = .Cells(AllCells.Row, 2)
            a(i, 3) = Evaluate("=SUBTOTAL(9,'" & shSurvey & "'" & "!D3:D" & Lastrow & ")")
            a(i, 4) = Evaluate("=SUBTOTAL(9,'" & shSurvey & "'" & "!E3:E" & Lastrow & ")")
            a(i, 5) = Evaluate("=SUBTOTAL(9,'" & shSurvey & "'" & "!F3:F" & Lastrow & ")")
            a(i, 6) = Evaluate("=SUBTOTAL(9,'" & shSurvey & "'" & "!G3:G" & Lastrow & ")")
        End With
        i = i + 1
    Next Item
    
    Worksheets(shData).Range("a3").Resize(UBound(a), UBound(a, 2)) = a
    Worksheets(shSurvey).AutoFilterMode = False
    Application.ScreenUpdating = False
    Erase a
    Set AllCells = Nothing
    Set Cell = Nothing
End Sub

**newbi004** · 08-24-2012, 12:21 PM

WOW!!! Worked perfectly Mike. I spent ages to search forums to get my answer...and you have provided it.

Thank you

ps This is now solved but I am not sure how I log it as solved

**NRSmith82** · 08-24-2012, 08:04 PM

I know this has been solved, but I was wondering what part of this would need to be edited if you wanted to add a few more columns of data that was also duplicate information to the row? For example, I have a name, number and two dates associated with the name that I need to keep together, but they are listed multiple times because they are associated with a different $ amount each time. This macro works great with my spreadsheet for the first two columns, but I cannot figure out how to make it go further to include the next two. Thank you!

**Cutter** · 08-25-2012, 08:29 AM

Hello NRSmith82, and welcome to the forum.

Unfortunately you have inadvertently broken one of the forum rules. Please read the following and make the necessary change. Thanks.

Your post does not comply with Rule 2 of our Forum RULES. Don't post a question in the thread of another member -- start your own thread. If you feel it's particularly relevant, provide a link to the other thread. It makes sense to have a new thread for your question because a thread with numerous replies can be off putting & difficult to pick out relevant replies.