Слияние ячеек с повторяющимися данными VBA

Question

Я пытаюсь получить макрос, чтобы объединить ячейки с повторяющимися данными. Он будет работать с небольшим количеством ячеек, но я получаю следующую ошибку, если попытаюсь запустить ее в большей группе ячеек. Я не уверен, есть ли более эффективный способ для excel, чтобы справиться с этим.

Ошибка выполнения «1004»: Метод «Range» объекта «_global» не удалось

Вот код:

Sub MergeDuplicates() 
Dim varData As Variant, varContent As Variant 
Dim strMyRange As String 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
    strMyRange = ActiveCell.Address 
    varContent = ActiveCell.Value 
    For Each varData In Selection.Cells 
     If varData.Value <> varContent Then 
      strMyRange = strMyRange & ":" & Cells(varData.Row - 1, varData.Column).Address & ", " & Cells(varData.Row, varData.Column).Address 
      varContent = Cells(varData.Row, varData.Column).Value 
     End If 
    Next 
    strMyRange = strMyRange & Mid(Selection.Address, InStr(1, Selection.Address, ":"), Len(Selection.Address)) 
    Range(strMyRange).Merge 
Application.DisplayAlerts = True 
Application.ScreenUpdating = True 
End Sub 

Answer 1

Я воссоздал проблему, используя код, который вы размещены и работает для меня. Я сделал то, что вы предложили, и поместил слияние в цикл For. Затем я разделяю strMyRange, используя запятую в качестве разделителя. Я установил тест для поиска символа «:» в TestArray (0). Если он находится в этой целевой строке, я знаю, что он готов к слиянию. После этого я возвращаю strMyRange в TestArray (1), который является началом следующего диапазона.

Примечание: я смог пройти через него с отладчиком с 100 ячейками, и он сработал. Затем я попытался запустить его без каких-либо кодовых точек останова, но он объединил все выбранные ячейки. Я поставил 1 секунду ожидания перед самым окончательным слиянием и, похоже, работает.

Вот код:

Sub MergeDuplicates() 
Dim varData As Variant, varContent As Variant 
Dim strMyRange As String 
Dim TestArray() As String 
Dim target As String 
Dim pos As Integer 




Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
strMyRange = ActiveCell.Address 
varContent = ActiveCell.Value 
For Each varData In Selection.Cells 
    If varData.Value <> varContent Then 
     strMyRange = strMyRange & ":" & Cells(varData.Row - 1, varData.Column).Address & ", " & Cells(varData.Row, varData.Column).Address 
     TestArray = Split(strMyRange, ",") 
     target = TestArray(0) 
     pos = InStr(target, ":") 
     If (pos > 0) Then 
      Range(target).Merge 
      strMyRange = TestArray(1) 
     End If 
     varContent = Cells(varData.Row, varData.Column).Value 
    End If 
Next 
strMyRange = strMyRange & Mid(Selection.Address, InStr(1, Selection.Address, ":"), Len(Selection.Address)) 
Application.Wait (Now + #12:00:01 AM#) 'This helps the application run OK if there are no breakpoints. 
Range(strMyRange).Merge 
Application.DisplayAlerts = True 
Application.ScreenUpdating = True 
End Sub