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

仅检查第一列是否有折叠

如果列＆＃34; 2＆＃34;到＆＃34;结束＆＃34;包含数字，它们将被总结

具有混合值（数字和字符串）可能会搞乱

＆＃34; A＆＃34;，＆＃34; 3＆＃34;，＆＃34; 5＆＃34;将是＆＃34; A，3,5和＃34;

＆＃34; 3＆＃34;，＆＃34; A＆＃34;，＆＃34; 5＆＃34;将是＆＃34; 3，A，5＆＃34;

但＆＃34; 3＆＃34;，＆＃34; 5＆＃34;，＆＃34; A＆＃34;将是＆＃34; 8，A＆＃34;

如果字符串是数字的，则
*将被删除

它会拉出第一行的所有值（对于每个合并的部分）

如果没有＆＃34;第一个＆＃34;值，第一个被显示为＆＃34;，值＆＃34;

如果所有单元格都为空，则输出也为空

空单元格将被忽略（＆＃34; A＆＃34;，＆＃34;＆＃34;，＆＃34; C＆＃34;将成为＆＃34; A，C＆＃34;）

将变量中的所有内容推送到更大的表格

Answer 2

我想＆＃34; Unmerge＆＃34;首先是单元格，然后使用集合来获取唯一值并创建循环。

 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 3

而不是处理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 4

已发布的其他变体：

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 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

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

MS Excel -Finding合并单元格＆amp;在相应的行中将信息组合在一起

5 个答案:

之前

后