Macro Needed to Concatenate Data in separate ROWS

Hello,


I need a simple macro that concatenate data in separate rows and put the result on sheet 2.
Please note that the rows can be more than 150000



Please see file attached (2 sheets)


THANK YOU

Hello
I have a awesome user defined function for you
Check if this helps...
Change the array to suit....

Thanks for help me....but your function doesn't works because the results have to include both two columns (written on blue on second sheet)

I think It is better a macro.




Someone can code it please?

Originally Posted by jindon

http://www.excelforum.com/excel-prog...ml#post3981768
Change to

Sub test()
    Dim a, i As Long
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 2)
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        .Item(a(i, 1)) = .Count + 1
                        a(.Item(a(i, 1)), 1) = a(i, 1)
                        a(.Item(a(i, 1)), 2) = a(i, 2)
                    Else
                        a(.Item(a(i, 1)), 2) = _
                        Join(Array(a(.Item(a(i, 1)), 2), a(i, 2)), "-")
                    End If
                End If
            Next
            i = .Count
        End With
        .Offset(, .Columns.Count + 2).Resize(i, 2).Value = a
    End With
End Sub

Sorry but It doesn't appears nothing on sheet 2 with this code;
And with the previous thread code you coded, with a large file sometimes It doesn't appear nothing or It says "end of memory error"

Or:

Sub hsv()
Dim sn, i As Long
With CreateObject("scripting.dictionary")
sn = Sheets(1).Range("a1", Sheets(1).Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
  For i = 1 To UBound(sn)
      If sn(i, 1) <> "" Then
       .Item(sn(i, 1)) = Join(Array(.Item(sn(i, 1)), sn(i, 2)))
       .Item(sn(i, 1)) = Replace(Replace(Trim(.Item(sn(i, 1))), " ", " - "), "--", " ")
      End If
    Next i
  Sheets(1).Range("H1").Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
 End With
End Sub

Make in the VBEditor an active connection to "Microsoft Scripting Runtime" checking References (Tools/References).

No, I've tried another time and that code on my original file doesn't works. (...also with few rows....)



Please see this original file I've attached at this post;
I need a simple macro that put the result on sheet 2



Thanks

No, It doesn't works on large file

Someone can code a macro that is able to do this?
vba20.xlsx
(I need that It put the results on sheet 2





this is the original (cutted file) where the macro will work.
22vba.xlsx



THANKS

Originally Posted by jindon

My code are both working on your file.

It may raise the error for the bulky data, so I said post back if you get the error.

Or maybe we are talking about different EXCEL.

Option Explicit

Sub test()
    Dim a, i As Long
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 2)
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        .Item(a(i, 1)) = .Count + 1
                        a(.Item(a(i, 1)), 1) = a(i, 1)
                        a(.Item(a(i, 1)), 2) = a(i, 2)
                    Else
                        a(.Item(a(i, 1)), 2) = _
                        Join(Array(a(.Item(a(i, 1)), 2), a(i, 2)), "-")
                    End If
                End If
            Next
            i = .Count
        End With
        .Offset(, .Columns.Count + 2).Resize(i, 2).Value = a
        Application.Goto .Offset(, .Columns.Count + 2).Cells(1), True
    End With
End Sub


Sub testToOtherSheet()
    Dim a, i As Long
    With Sheets("1")
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 2).Value
    End With
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If a(i, 1) <> "" Then
                If Not .exists(a(i, 1)) Then
                    .Item(a(i, 1)) = .Count + 1
                    a(.Item(a(i, 1)), 1) = a(i, 1)
                    a(.Item(a(i, 1)), 2) = a(i, 2)
                Else
                    a(.Item(a(i, 1)), 2) = _
                    Join(Array(a(.Item(a(i, 1)), 2), a(i, 2)), "-")
                End If
            End If
        Next
        i = .Count
    End With
    With Sheets("2").Cells(1).Resize(i, 2)
        .CurrentRegion.ClearContents
        .Value = a
    End With
End Sub

Hello,

Your code works on the test file;
But If I try the macro on the original file (larger) It doesn't appears nothing on second sheet.






thanks



thanks

Hello jindon,


Your code worked well:

    Sub testToOtherSheet()
        Dim a, i As Long, n As Long
        With Sheets("1")
            a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 2).Value
        End With
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 1) <> "" Then
                    If Not .exists(a(i, 1)) Then
                        .Item(a(i, 1)) = .Count + 1
                        a(.Item(a(i, 1)), 1) = a(i, 1)
                        a(.Item(a(i, 1)), 2) = a(i, 2)
                    Else
                        a(.Item(a(i, 1)), 2) = _
                        Join(Array(a(.Item(a(i, 1)), 2), a(i, 2)), "-")
                    End If
                End If
            Next
            n = .Count
        End With
        With Sheets("2").Cells(1)
            .CurrentRegion.ClearContents
            For i = 1 To n
                .Cells(i, 1).Value = a(i, 1)
                .Cells(i, 2).Value = a(i, 2)
            Next
        End With
    End Sub

But now I'm working with these very heavvy files (more than 150000 rows) and It says me: end of memory.


Can you make the code works for this kind of big files??







thank you VERY much