MS Excel - 查找合并的单元格并在相应行中组合信息

Question

A列中有一些合并的单元格和一些未合并的单元格，大小不同，B列由所有未合并的单元格组成。

我正在寻找一个公式（如果不存在，可以用 VBA 编写），它将确定单元格在 A 中是合并还是未合并，如果合并，则合并 B 列中的组件（如公式连接确实）并将其写入其中一行，比如上面的一行，如果可能的话，删除下面的行。

我可以用公式来做到这一点吗？谁能帮我提供给定的代码？

---

现在我不想丢失给定行的数据，而是在它们之间添加第 3 列和第 4 列的数据，如图所示。如果可能的话，让星星消失。

Answer 1

为了使其快速简单：（将其放在 VBA 窗口中的任何模块中）

Option Explicit

Public Function merge_merged(rng As Range) As Variant
  Dim i As Long, j As Long, output() As Variant
  ReDim output(1 To UBound(rng.Value), 1 To 2)
  For j = 1 To UBound(rng.Value)
    If Len(rng(j, 1).Text) Then
      i = i + 1
      output(i, 1) = rng(j, 1).Text
      output(i, 2) = rng(j, 2).Text
    Else
      output(i, 2) = output(i, 2) & ", " & rng(j, 2).Text
    End If
  Next
  For i = i + 1 To j - 1
    output(i, 1) = ""
    output(i, 2) = ""
  Next
  merge_merged = output
End Function

然后选择范围 D2:E13 并使用公式

=merge_merged(B2:C13)

这是一个数组公式，必须用Ctrl+Shift+Enter↵确认。

应该完全按照你的要求去做......如果你还有任何问题，请写评论

也适用于我的字符串：

编辑：

得到你想要的答案后，你不应该改变问题，最好问一个新的。不过，这次我会提供一个解决方案：

Option Explicit

Public Function merge_merged(rngIn As Range) As Variant
  Dim i As Long, j As Long, k As Long, output() As Variant, rng As Variant
  rng = rngIn.Value
  ReDim output(1 To UBound(rng), 1 To UBound(rng, 2))
  For j = 1 To UBound(rng)
    If Len(rng(j, 1)) Then
      i = i + 1
      For k = 1 To UBound(output, 2)
        If IsNumeric(Replace(rng(j, k), "*", "")) Then
          output(i, k) = Replace(rng(j, k), "*", "")
        Else
          output(i, k) = rng(j, k)
        End If
      Next
    Else
      For k = 1 To UBound(output, 2)
        If Len(rng(j, k)) Then
          If IsNumeric(output(i, k)) And IsNumeric(Replace(rng(j, k), "*", "")) Then
            output(i, k) = 0 + output(i, k) + Replace(rng(j, k), "*", "")
          Else
            output(i, k) = output(i, k) & ", " & rng(j, k)
          End If
        End If
      Next
    End If
  Next
  For i = i + 1 To j - 1
    For k = 1 To UBound(output, 2)
      output(i, k) = ""
    Next
  Next
  merge_merged = output
End Function

• 只会检查第一列是否折叠
• 如果“2”到“end”列包含数字，则将它们相加
  • 具有混合值（数字和字符串）可能会搞砸
    • “A”、“3”、“5”将是“A、3、5”
    • “3”、“A”、“5”将是“3、A、5”
    • 但“3”、“5”、“A”将是“8、A”
  • * 如果字符串是数字的，将被删除
• 它将提取第一行的所有值（对于每个合并的部分）
  • 如果没有“first”值，则找到的第一个将显示为“, value”
  • 如果所有单元格都为空，则输出也将为空
• 空单元格将被忽略（“A”、“”、“C”将变为“A、C”）
• 将变量中的所有内容都推送到更大的表中以加快速度

Answer 2

与其处理Range.MergeArea property，不如简单地Range.UnMerge method 有问题的单元格并以不同于仍然填充的空白的方式处理生成的空白。

Sub flatten_merge()
    Dim rw As Long, v As Long, vVALs As Variant

    With Worksheets("Sheet1")
        .Columns(1).UnMerge
        ReDim vVALs(1 To Application.Count(.Columns(1)), 1 To 2)
        For rw = 1 To .Cells(Rows.Count, "B").End(xlUp).Row
            If IsEmpty(.Cells(rw, 1)) Then
                vVALs(v, 2) = vVALs(v, 2) & Chr(44) & .Cells(rw, 2).Value2
            Else
                v = v + 1
                vVALs(v, 1) = .Cells(rw, 1).Value2
                vVALs(v, 2) = .Cells(rw, 2).Value2
            End If
        Next rw
        .Cells(1, 1).Resize(1, 2).EntireColumn.Clear
        .Cells(1, 1).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
    End With
End Sub

如果您需要保留原件，只需简单修改即可将源复制到新位置。

样本数据和结果：

             
                 ^{之前                             之后}

Answer 3

已发布的其他变体：

Sub tets()
    Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
    Dim cl As Range, Data As Range, k, s%
    Dic.comparemode = vbTextCompare
    Set Data = Range("A1:A" & [A:A].Find("*", , , , xlByRows, xlPrevious).Row)
    For Each cl In Data
       If cl.Value2 <> "" Then s = cl.Value2
        If Not Dic.exists(s) Then
            Dic.Add s, cl.Offset(, 1).Value2
        Else
            Dic(s) = Dic(s) & "," & cl.Offset(, 1).Value2
        End If
    Next cl
    For Each k In Dic
        Debug.Print k, Dic(k)
    Next k
End Sub

测试

Answer 4

我想先“取消合并”单元格，然后使用集合来获取唯一值并创建一个循环。

 Sub uNMERGE()
    Dim rng As Range, lstRw As Long, c As Range

    Columns("A:A").MergeCells = 0

    lstRw = Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A1:A" & lstRw)

    For Each c In rng.Cells

        If c = "" Then
            c = c.Offset(-1)
        End If

    Next c

    UsingColection
End Sub
Sub UsingColection()
    Dim cUnique As Collection
    Dim rng As Range, c As Range
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant
    Dim rws As Long, s As String

    Set sh = ThisWorkbook.Sheets("Sheet1")
    rws = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
    Set rng = sh.Range("A1:A" & rws)
    Set cUnique = New Collection

    On Error Resume Next
    For Each Cell In rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0

    For Each vNum In cUnique
        Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = vNum

        For Each c In rng.Cells
            If c = vNum Then
                s = s & c.Offset(, 1) & ","
            End If
        Next c

        Cells(Rows.Count, "D").End(xlUp).Offset(0, 1) = Mid(s, 1, Len(s) - 1)
        s = ""

    Next vNum

End Sub 

之前

之后

Answer 5

那么这段代码有什么问题呢？ - 因为它给出了#VALUE！每个选定的单元格都有错误。

Option Explicit

Public Function merge_merged(rng As Range) As Variant

  Dim i As Long, j As Long, output() As Variant
  ReDim output(1 To UBound(rng.Value), 1 To 4)
  For j = 1 To UBound(rng.Value)
    If Len(rng(j, 1).Text) Then
      i = i + 1
      output(i, 1) = rng(j, 1).Text
      output(i, 2) = rng(j, 2).Text
      output(i, 3) = rng(j, 3).Value
      output(i, 4) = rng(j, 4).Value
      output(i, 5) = rng(j, 5).Text

    Else
      output(i, 2) = output(i, 2) & ", " & rng(j, 2).Text
      output(i, 3) = output(i, 3) + rng(j, 3).Value
      output(i, 4) = output(i, 4) + rng(j, 4).Value
      output(i, 5) = rng(j, 5).Text
    End If
  Next
  For i = i To j - 1
    output(i, 1) = ""
    output(i, 2) = ""
    output(i, 3) = ""
    output(i, 4) = ""
    output(i, 5) = ""
  Next
  merge_merged = output
End Function
Sub ece()
End Sub

我还能做些什么来搜索“明星”？并创建一个新列来引用每个单元格中的数据（即使曾经合并）是否有“星号”？