Finding the highest value in a column and changing the group

[abuchan]

Attached is a sample file which is part of a bigger project which is slowly coming together. Sheet1 includes three columns (A) 'parcelnumber', (B) 'improv_id', and (C) 'bld_num'. I need to create a fourth column which shows how many (total) buildings are associated with a specific parcel number. On Sheet 2, I have hand-created what I am trying to obtain. In essence, I am hoping to show that an improvement is 3 of 4 or 1 of 1 or 7 of 15 and so on. The 'real' file has approximately 40,000 entries so it is a little more than is realistic. Also, as this is part of a bigger project, I am hoping to complete this task as a macro.

Thank you for any insight you can provide.

[rylo]

Hi

I think this formula will give you the result you want.

=COUNTIF($A$1:$A1,A1) & " of " & COUNTIF($A$1:$A$157,A1)

If so, then have a macro put it into the first output cell, then have it copied down. You could then convert to a value if required.

rylo

[abuchan]

Thank you but please excuse my ignorance, I have no idea of what to do with it. Everything I know about Excel I have learned through this site, but my confidence level does not yet include taking a statement like this and making a macro out of it...

[abuchan]

As I don't understand the solution provided, I am attaching my attempt hoping for a little direction. My attempt copies the data from the previous page but I still can't get column D to produce.

Sub MoveData()
Dim LR As Long, a As Long, NR As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
ws2.Cells.ClearContents
LR = ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
NR = 2
For a = 2 To LR + 1 Step 1
    Application.CutCopyMode = False
  ws2.Cells(NR, 1) = ws1.Cells(a, 1)
  ws2.Cells(NR, 2) = ws1.Cells(a, 2)
  ws2.Cells(NR, 3) = ws1.Cells(a, 3)
        If ws1.Cells(a, 1) = ws1.Cells(a - 1, 1) Then
            ws2.Cells(NR, 4) = ws1.Cells(a - 1, 4)
            ElseIf ws1.Cells(a, 1) <> ws1.Cells(a - 1, 1) Then
        ws2.Cells(NR, 4) = ws1.Cells(a, 4)
        End If
    
  NR = NR + 1
  Next a
ws2.UsedRange.Columns.AutoFit
ws2.Select
Application.ScreenUpdating = True
End Sub

This is based on the active sheet being sorted with Column C from most to least.

Thank you.

[Leith Ross]

Hello Alec,

I time tested this macro by copying the 157 rows of your test data to make over 40000 rows. On my computer this took only about 1 second to complete. This has been added to the attached workbook.

'Written: April 08, 2010
'Author:  Leith Ross
'Summary: Counts the number times a parcel number appears in the list. The final totals
'         are displayed next to each invidual parcel number in column "D". The parcels
'         do not have to be presorted for the macro to work properly.

Sub CountXofY()

  Dim Cell As Range
  Dim Counts() As Variant
  Dim DSO As Object
  Dim Key As String
  Dim Item As Long
  Dim Parcels() As Variant
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Sheet1")
    
    Set Rng = Wks.Range("A2")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
    
    ReDim Parcels(1 To Rng.Rows.Count, 1 To 1)
    ReDim Counts(1 To Rng.Rows.Count, 1 To 1)
    
    Parcels = Rng.Value
    
    Set DSO = CreateObject("Scripting.Dictionary")
    DSO.CompareMode = vbTextCompare
    
      For Each Cell In Rng
        Key = Trim(Cell.Text)
        Item = Cell.Offset(0, 2)
        If Key <> "" Then
          If Not DSO.Exists(Key) Then
            DSO.Add Key, 1
          Else
            DSO(Key) = DSO(Key) + 1
          End If
        End If
      Next Cell
      
      For I = 1 To UBound(Parcels)
        Counts(I, 1) = DSO(Parcels(I, 1))
      Next I
      
      Application.ScreenUpdating = False
        Rng.Offset(0, 3).Value = Counts
      Application.ScreenUpdating = True
      
    Set DSO = Nothing
    
End Sub

[abuchan]

Works like a charm. Must be on Sheet 1, but it probably says that in Galic somewhere
Thank you.