Excel VBA - 增量检查和合并

Question

好的，所以我在这里提出我的第一个问题，如有任何歧义，请提前道歉。

我正在处理通过 SQL 提取数据并将其复制到某个表的工作表。数据包含字符串值。我目前正在使用 vba 来提取数据（因为涉及到变量），并将其复制到我想要的网格中。

问题来了；复制数据后，我必须合并某些单元格（有时两个有时 3 个），我手动执行此操作。条件是如果 C13 = C14 然后合并，如果我合并 C13 和 C14，我也必须合并 B13 和 B14，以及 D13 和 D14。接下来我要检查合并的单元格（现在是C13）是否等于C15，然后将C13合并到C15，如果这个条件为真那么B＆D也将被合并。

如果 C13 的条件不成立，即 C13 C14 我想转到下一个单元格 C14 并检查 C14 = C15 是否。

我想用 vba 执行此操作，但尝试手动执行此操作会遇到数英里的代码，有人可以帮忙吗？

这是我在这里找到的代码的开始并设法改变了一点，但现在我迷路了

Sub Merge()
    Dim k As Range, cell As Range, name As String
    Set k = Range("C13:C50")
    For Each cell In k
        If cell.Value =

        End If
    Next
End Sub

Answer 1

我可以向您推荐以下代码：

Sub Merge()
    Dim k As Range, cell As Range, name As String
    Set k = Range("C13:C50")
    Application.DisplayAlerts = False
Do_it_again:
    For Each cell In k
        If cell.Value = cell.Offset(1, 0).Value _
            And IsEmpty(cell) = False Then
            Debug.Print cell.Address
            'for column C
            Range(cell, cell.Offset(1, 0)).Merge
            'for column B
            cell.Offset(0, -1).Resize(cell.MergeArea.Rows.Count, 1).Merge
            'for column D
            cell.Offset(0, 1).Resize(cell.MergeArea.Rows.Count, 1).Merge
            GoTo Do_it_again
        End If
    Next
    Application.DisplayAlerts = True
End Sub

我不需要喜欢我提出的代码，但毕竟它的工作原理如下所示。

编辑以提高效率 我不得不承认，以前的代码对于大数据表效率不高，比如 5000 行或更多。下面的一个速度提高了 90%，但仍然需要大约 10-20 秒来处理 5000 行数据。

与上面的代码相比，最重要的更改标记为 *****。

Sub Merge()
    Dim k As Range, cell As Range, name As String
    Dim kStart As Range, kEnd As Range '*****
        Set kStart = Range("C13")      '*****
        Set kEnd = Range("C8000")      '*****

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False       '*****
Do_it_again:
    For Each cell In Range(kStart, kEnd)     '*****
        If cell.Value = cell.Offset(1, 0).Value _
            And IsEmpty(cell) = False Then
            Application.StatusBar = cell.Address  '***** check progress in Excel status bar

            'for column C
            Range(cell, cell.Offset(1, 0)).Merge
            'for column B
            cell.Offset(0, -1).Resize(cell.MergeArea.Rows.Count, 1).Merge
            'for column D
            cell.Offset(0, 1).Resize(cell.MergeArea.Rows.Count, 1).Merge
            Set kStart = cell      '*****
            GoTo Do_it_again
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True      '*****
End Sub

Answer 2

抱歉，忘记初始化 count @ 14

current = cells(13,3)
count = 14
for i = 14 to 15
next = cells(i,3)
If current = next then
    'match encountered, merge columns B,C,D
    for j = 2 to 4
        cells(13,j) = cells(13,j) & cells(count,j)
    next j
    count = count + 1
end if
next i

如果您不尝试追加，而是将 C13 的值替换为 C14（如果匹配），将 C13 的值替换为 C15（如果匹配）等等...，然后更改行

cells(13,j) = cells(13,j) & cells(count,j)

到

cells(13,j) = cells(count,j)