CODEWITHSUNDEEP
excelvbamergerow
Alfa Bachtiar
Alfa Bachtiar

Reputation: 73

Merge certain row, based on unique value with vba. any faster method?

lately i tried to merge some row, based on unique value. long description typed not in one row, but more. what i want is, long description that typed in different row merge in one row. based on its number and short description.

input

>     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

output

>     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

what i've tried :

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

the problem occured when i handle about 300.000 rows of data, ms excel said that the range just too much, so i made a repetition about ten times to make it works. but the program going very VERY slow, i've waited about one hour and it's not done yet. is there any possible method to do this? faster one? or lighter one?

Upvotes: 0

Views: 203

Answers (1)

Tim Williams
Tim Williams

Reputation: 166146

Reading from and writing to worksheets frequently can hit your performamce pretty hard, so better to transfer data in batches using arrays.

Here's an example of an approach you could take. Tested on ~400k lines of input: took <3sec on my 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

Upvotes: 1

Related Questions