1

好的,所以我在这里提出我的第一个问题,对任何含糊之处深表歉意。

我正在处理一张通过 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
4

2 回答 2

0

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

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%,但对于 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
于 2013-06-26T21:55:39.220 回答
0

抱歉,忘记初始化 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)
于 2013-06-26T21:56:35.387 回答