CODEWITHSUNDEEP
functionexcelxlsvba
joshpt
joshpt

Reputation: 733

Excel Macro to concatenate multiple rows from Column B per ID rows in Column A with newlines

This problem is in an Excel .xls file.

Simplest Use Case:

Column A has one row. Column B has 5 rows. The 5 rows in Column B need to be merged into one row, delimited by newlines.

I have a huge .xls document where there are a ton of IDs in column A. There are on average anywhere from 3 to 10 rows that belong to each column A row.

How to know which Column B rows belong to which Column A? By the positioning of the cells. One Column A row may have 5 Column B rows to the right of it.

I don't have any VBA experience. I have looked around for macros and functions but haven't had any luck finding anything that matches this problem.

Edit: I am now trying to figure out how to get the script to ignore rows that have a one-to-one mapping between column A and column B.

Edit again - 06-20-2012: Now that I can attach images, here is a screenshot of an image for what I'm trying to get.
The rows for Brian and Mark should be ignored, while Scott and Tim get their values copied over.

results that I'm looking for


Edit: Unmerging column A, using the code that Andy supplied, and then using this VB script afterwards does the trick:

Sub mergeA()
For i = 2 To Cells(65535, 1).End(xlUp).Row
If IsEmpty(Cells(i, 1)) Then Range(Cells(i - 1, 1), Cells(i, 1)).Merge
Next
End Sub

That VB script puts the cells in column A back together
I didn't make the script, it came from this web page:
http://www.vbforums.com/showthread.php?t=601304

Upvotes: 0

Views: 9274

Answers (1)

andy holaday
andy holaday

Reputation: 2302

This will transform the data shown on the left to the output on the right:

enter image description here enter image description here

Option Explicit

Sub Make_Severely_Denormalized()
  Const HEADER_ROWS As Long = 1
  Const OUTPUT_TO_COLUMN As Long = 3
  Const DELIMITER As String = vbNewLine
  Dim A_Range As Range
  Dim B_Range As Range
  Dim A_temp As Range
  Dim B_temp As Range
  Dim B_Cell As Range
  Dim Concat As String

On Error GoTo Whoops
  Set A_Range = Range("A1").Offset(HEADER_ROWS)
  Do While Not A_Range Is Nothing
    Set B_Range = A_Range.Offset(0, 1)

    ' some helper ranges
    If A_Range.Offset(1, 0).Value = "" Then
      Set A_temp = Range(A_Range, A_Range.End(xlDown).Offset(-1, 0))
    Else
      Set A_temp = A_Range.Offset(1, 0)
    End If
    Set B_temp = Range(B_Range, B_Range.End(xlDown)).Offset(0, -1)

    ' determine how high "B" is WRT no change in "A"
    Set B_Range = Range(B_Range, B_Range.Resize( _
      Application.Intersect(A_temp, B_temp, ActiveSheet.UsedRange).Count))

    ' loop through "B" and build up the string
    Concat = ""
    For Each B_Cell In B_Range
      Concat = Concat & B_Cell.Value & DELIMITER
    Next
    Concat = Left(Concat, Len(Concat) - Len(DELIMITER))

    ' do the needful
    A_Range.Offset(0, OUTPUT_TO_COLUMN - 1).Value = Concat

    ' find the next change in "A"
    If A_Range.Offset(1, 0).Value = "" Then
      Set A_Range = Application.Intersect(A_Range.End(xlDown), ActiveSheet.UsedRange)
    Else
      Set A_Range = A_Range.Offset(1, 0)
    End If
  Loop
  Exit Sub
Whoops:
  MsgBox (Err & " " & Error)
  Stop
  Resume Next
End Sub

Upvotes: 1

Related Questions