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行数据时出现问题，ms excel表示范围太大，所以我重复了十次以使其工作。但程序非常慢，我等了大约一个小时，但还没有完成。有没有可行的方法来做到这一点？更快一个？还是打火机？

Answer 1

经常阅读和写入工作表可能会很难达到您的性能，因此最好使用数组批量传输数据。

以下是您可以采取的方法示例。在~400k输入线上测试：在我的电脑上拍摄<3秒。

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

根据vba的唯一值合并某一行。任何更快的方法？

1 个答案: