1

我正在尝试从中获取一个 excel 表：（对不起，我的声誉不够高，无法发布图片，所以我自己托管了它们..）

从这个例子

至

这个。

我找到并修改了一些 VBA 代码：

管理这些 excel 表的女孩没有按帐号预先排序，就像我在上面的第一个屏幕截图中所做的那样，所以也在下面的代码中 

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）不需要一个小时运行的解决方案。

我曾尝试用以下方式交换该行：

If Len(Trim(oCell)) = 0 Then

但是，当您进入 100 多行帐户时，需要很长时间。

有没有其他方法可以排序然后合并行而不会丢失底片或花一个小时运行？

我确信有一个简单的解决方案。但我是 VBA 代码的新手。

谢谢，

4

1 回答 1

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
于 2013-09-16T22:54:41.777 回答