vba Excel 宏将 A 列中每个 ID 行的 B 列中的多行与换行符连接起来

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

提问by joshpt

This problem is in an Excel .xls file.

此问题出在 Excel .xls 文件中。

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.

A 列有一行。B 列有 5 行。B 列的 5 行需要合并为一行，以换行符分隔。

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.

我有一个巨大的 .xls 文档，其中 A 列中有大量 ID。平均有 3 到 10 行属于每一列 A 行。

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.

如何知道 B 列的哪些行属于 A 列？通过定位细胞。一个 A 列行的右侧可能有 5 个 B 列行。

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.

我没有任何 VBA 经验。我四处寻找宏和函数，但没有找到任何与此问题匹配的东西。

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.

编辑：我现在试图弄清楚如何让脚本忽略在 A 列和 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.

再次编辑 - 2012 年 6 月 20 日：现在我可以附加图像了，这是我想要获取的图像的屏幕截图。
Brian 和 Mark 的行应该被忽略，而 Scott 和 Tim 会复制他们的值。

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

编辑：使用 Andy 提供的代码取消合并 A 列，然后使用此 VB 脚本即可解决问题：

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

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) ). 合并
下一个
结束子

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

该 VB 脚本将 A 列中的单元格重新组合在一起
我没有制作脚本，它来自这个网页：http:
//www.vbforums.com/showthread.php?t=601304

回答by andy holaday

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

这会将左侧显示的数据转换为右侧的输出：

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