Excel VBA - 增量检查和合并

Question

好的，所以在这里我带着我的第一个问题，提出任何含糊不清的道歉。

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

问题来了;在我复制了数据之后，我必须合并某些单元格（有时候两个有时候是三个），然后手动完成。条件是如果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％，但对于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 

如果你是不是要追加，但如果匹配等与C14，如果匹配，C13与C15取代C13的价值... ，则线

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

更改为

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