Question

好的，所以我在这里提出第一个问题，对任何含糊不清的事情表示道歉。

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

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

如果C13的条件不成立，即C13＆lt; C13＆gt; 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

我没有必要像我提出的代码一样，但毕竟它的工作方式如下所示。

enter image description here

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

与上述代码相比，最重要的变化标记为*****。

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

抱歉，忘记初始化计数@ 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)

Excel VBA - 增量检查和合并

2 个答案: