VBA Code - объединение строк первенствовать с отрицательными числами

Question

Я пытаюсь получить лист первенствовать, чтобы перейти от этого: (извините моя репутация не достаточно высока, чтобы размещать фотографии, так что принимал их сам ..)

From this example

в

this.

Я некоторые VBA код, который я нашел и модифицирована:

Девушка, которая управляет этим первенствует листы не предварительно сортировать по номеру счета, как я сделал в первом скриншоте выше, так что также в коде ниже

Sub MergeRows() 
Dim iRow As Long, oCell As Object 
Sheets(1).Activate 
Columns("A:H").Select 
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ 
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
DataOption1:=xlSortTextAsNumbers 
iRow = 1 
Do While Len(Cells(iRow, 1)): DoEvents 
If Cells(iRow, 1) = Cells(iRow + 1, 1) Then 
For Each oCell In Rows(iRow).Cells 
If oCell < Cells(iRow + 1, oCell.Column) Then 
oCell = Cells(iRow + 1, oCell.Column) 
End If 
Next 
Rows(iRow + 1).Delete 
Else 
iRow = iRow + 1 
End If 
Loop 
End Sub 

Однако

If oCell < Cells(iRow + 1, oCell.Column) Then 

строка, похоже, вызывает удаление отрицательных чисел, поскольку они не больше, чем пустые ячейки над ними. (правильно?), и я не могу найти решение, что A) не удаляет отрицательные числа, а B) не требует часа для запуска.

Я попытался swaping этой строки с:

If Len(Trim(oCell)) = 0 Then 

Но когда вы получаете в 100+ строк счетов это занимает очень много времени.

Есть ли какой-то другой способ, который мы можем сортировать, тогда объединить строки, не теряя негативов, или потратив час на запуск?

Я уверен, что это простое решение. Но я новичок в коде VBA.

Спасибо,

Answer 1

Этот код не требует, чтобы данные были отсортированы, и это будет правильно сохранить негативы. Он должен работать довольно быстро:

Sub MergeRows() 

    Dim ws As Worksheet 
    Dim rngUnqAccts As Range 
    Dim arrData() As Variant 
    Dim arrResults() As Variant 
    Dim rIndex As Long 
    Dim cIndex As Long 
    Dim ResultIndex As Long 


    Set ws = Sheets(1) 
    With ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp)) 
     If .Row < 2 Then Exit Sub 'No data 
     ws.Range("A1", .Cells(.Cells.Count)).AdvancedFilter xlFilterCopy, , ws.Cells(1, ws.Columns.Count), True 
     Set rngUnqAccts = Range(ws.Cells(2, ws.Columns.Count), ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp)) 
     arrData = .Resize(, Columns("H").Column).Value 
     ReDim arrResults(1 To rngUnqAccts.Cells.Count, 1 To UBound(arrData, 2)) 
    End With 

    For rIndex = LBound(arrData, 1) To UBound(arrData, 1) 
     ResultIndex = WorksheetFunction.Match(arrData(rIndex, 1), rngUnqAccts, 0) 
     If IsEmpty(arrResults(ResultIndex, 1)) Then 
      arrResults(ResultIndex, 1) = arrData(rIndex, 1) 
      arrResults(ResultIndex, 2) = arrData(rIndex, 2) 
     End If 
     For cIndex = 3 To UBound(arrData, 2) 
      If Len(arrData(rIndex, cIndex)) > 0 Then arrResults(ResultIndex, cIndex) = arrData(rIndex, cIndex) 
     Next cIndex 
    Next rIndex 
    rngUnqAccts.EntireColumn.Clear 

    ws.Range("A2:A" & Rows.Count).Resize(, UBound(arrData, 2)).ClearContents 
    ws.Range("A2").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults 


    Set ws = Nothing 
    Set rngUnqAccts = Nothing 
    Erase arrData 
    Erase arrResults 

End Sub