根据 vba 的唯一值合并某些行。有更快的方法吗？

Question

最近我尝试根据唯一值合并一些行。长描述不是一行，而是更多。我想要的是，在不同行中键入的长描述合并在一行中。基于其编号和简短描述。

输入

>     Number | short Desc | long desc
>     
>     1      | helmet 46  | replica of valentino rossi's helmet
>     
>                         | limited edition only 1000unit
>     
>                         | manufactured in japan
>     
>                         | 2011 production
>     
>     
>     
>     2      | V mask     | replica of vandetta mask
>     
>                         | polycarbonate
>     
>                         | manufactured in bandung, indonesia
>     
>                         | 2009 production

输出

>     Number | short Desc | long desc

>     1      | helmet 46  | replica of valentino rossi's helmet, limited edition only  1000unit, manufactured in japan, 2011 production

>     
>     2      | V mask     | replica of vandetta mask, polycarbonate, manufactured in bandung, indonesia, 2009 production

我尝试过的：

Sub longdesc()
Dim desc As String
Dim sapnbr As Variant
Dim order As String

x = 1
i = 2
y = 3

Range("A2:A30000").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"


desc = Worksheets("Control Deck").Cells(i, 3).Value
Do While Worksheets("Control Deck").Cells(i, 1).Value <> ""
sapnbr = Worksheets("Control Deck").Cells(i, 1).Value
order = Worksheets("Control Deck").Cells(i, 2).Value
    If sapnbr = Worksheets("Control Deck").Cells(i + 1, 1).Value Then
    desc = desc & Worksheets("Control Deck").Cells(i + 1, 3).Value
    Else
       Worksheets("Process").Cells(x, 2).Value = order
       Worksheets("Process").Cells(x, 1).Value = sapnbr
       Worksheets("Process").Cells(x, 3).Value = desc
       desc = Worksheets("Control Deck").Cells(i + 1, 3).Value
       x = x + 1
    End If
i = i + 1
Loop

Sheets("Process").Select
Range("A1:C9000").Cut Destination:=Range("A2:C9001")
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Material Number"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Short Description"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Long Description"

End Sub

当我处理大约 300.000 行数据时出现问题，excel 女士说范围太大，所以我重复了大约十次以使其正常工作。但是程序非常慢，我等了大约一个小时，还没有完成。 有没有可能的方法来做到这一点？更快的一个？还是更轻的？

Answer 1

频繁地读取和写入工作表可能会严重影响您的性能，因此最好使用数组批量传输数据。

这是您可以采取的方法的示例。在大约 400k 行输入上测试：在我的 PC 上花费了

Sub Tester()

Dim shtIn As Worksheet, shtOut As Worksheet
Dim arrIn, arrOut
Dim ub As Long, r As Long, r2 As Long
Dim num, order, desc

    Set shtIn = ThisWorkbook.Sheets("Control Deck")
    Set shtOut = ThisWorkbook.Sheets("Process")

    'load the input data to an array
    arrIn = shtIn.Range(shtIn.Range("A1"), shtIn.Cells(Rows.Count, 3).End(xlUp)).Value

    ub = UBound(arrIn, 1)
    'resize the output array to match (worst case size...)
    ReDim arrOut(1 To ub, 1 To 3)
    r2 = 1

    For r = 1 To ub
        'is this row the start of a new item?
        If Len(arrIn(r, 1)) > 0 Then
            'output any previous item to the second array
            If Len(num) > 0 Then
                arrOut(r2, 1) = num
                arrOut(r2, 2) = order
                arrOut(r2, 3) = desc
                r2 = r2 + 1
            End If
            'store the current item info
            num = arrIn(r, 1)
            order = arrIn(r, 2)
            desc = arrIn(r, 3)
        Else
            'still on the same item, so add to the description
            desc = desc & ", " & arrIn(r, 3)
        End If

    Next r

    'add the last item...
    If Len(num) > 0 Then
        arrOut(r2, 1) = num
        arrOut(r2, 2) = order
        arrOut(r2, 3) = desc
    End If

    'add header
    shtOut.Cells(1, 1).Resize(1, 3).Value = _
      Array("Material Number", "Short Description", "Long Description")

    'dump the output array to the worksheet
    shtOut.Cells(2, 1).Resize(r2, 3).Value = arrOut

End Sub