Book index - need help joining page numbers when consecutive

[sealgmg2]

Hi,

I'm working on a catalog index and have product keywords in column A (repeated on additional rows if they reference more than one page), and the page numbers in column B.

Keyword	Page No.
Telephone	350
Telephone	351
Telephone	352
Telephone	400

<TBODY>
</TBODY>

What I'd like to end up with is:

Keyword	Page No.
Telephone	350-352, 400

<TBODY>
</TBODY>

I'm working in MS Excel 2007 on a PC running Windows Vista.

Thanks for any help you can provide.

Scott

 

[Fazza]

hi, Scott. This looks a bit of a mess. Hopefully does what you want. Regards

Sub maybe()

  'assumes
  'keyword header in cell A1
  'page number header in B1
  'detailed data in contiguous block
  'contiguous data is range "A1:Bxx", x>=2
  'column C empty

  Dim i As Long, j As Long
  Dim lngFirstInGroup As Long
  Dim arIN As Variant, arOUT As Variant

  arIN = Range("A1").CurrentRegion.Value2
  ReDim arOUT(1 To UBound(arIN, 1), 1 To 2)

  arOUT(1, 1) = arIN(1, 1)
  arOUT(1, 2) = arIN(1, 2)
  j = 1

  'loop from the first data row
  i = 2

  Do
    'keep track of the first page number for this loop/sequence
    lngFirstInGroup = arIN(i, 2)

    'for the current keyword, identify the last row in a range of sequential page numbers
    'do this by looping until either the last record is reached or the next record has a different keyword
    Do While i < UBound(arIN, 1)
      If arIN(i, 1) = arIN(i + 1, 1) And arIN(i, 2) + 1 = arIN(i + 1, 2) Then
        i = i + 1
      Else
        Exit Do
      End If
    Loop
    'now record i is the last in the sequence

    'check if new output record or not
    If arIN(i, 1) <> arOUT(j, 1) Then
      'create the next output record
      j = j + 1
      'with keyword...
      arOUT(j, 1) = arIN(i, 1)
    End If

    'load the page record...
    'if there is only one page number
    If arIN(i, 2) = lngFirstInGroup Then
      'if there is no text already
      If Len(arOUT(j, 2)) = 0 Then
        arOUT(j, 2) = arIN(i, 2)
      Else
        'otherwise append it to whatever is already there
        arOUT(j, 2) = arOUT(j, 2) & ", " & arIN(i, 2)
      End If
    Else
      'when there is a range of page numbers
      'if there is no text already
      If Len(arOUT(j, 2)) = 0 Then
        arOUT(j, 2) = lngFirstInGroup & "-" & arIN(i, 2)
      Else
        'otherwise append it to whatever is already there
        arOUT(j, 2) = arOUT(j, 2) & ", " & lngFirstInGroup & "-" & arIN(i, 2)
      End If
    End If

    i = i + 1
  Loop Until i >= UBound(arIN, 1)

  'and check the last record...
  If i = UBound(arIN, 1) Then
    'if it is the same keyword
    If arIN(i, 1) = arOUT(j, 1) Then
      arOUT(j, 2) = arOUT(j, 2) & ", " & arIN(i, 2)
    Else
      'new keyword
      j = j + 1
      arOUT(j, 1) = arIN(i, 1)
      arOUT(j, 2) = arIN(i, 2)
    End If
  End If

  Range("A1").CurrentRegion.Value = arOUT

End Sub

 

[sealgmg2]

Fazza,

Thanks so much. This works great and is nicely annotated so I can follow along. I really appreciate your help on this and the time you spent to help a stranger work more efficiently. Thanks again...I hope to someday pay it forward as you have done for me.

Scott