Copy and merge specific column content Urgent help please with excel macro

Hi All,

Attached file has 2 sheets 1 is what i have a raw file with 20K rows of data and i want it finally as "Output" sheet

Need to get the name from column "C" and than trim the code after = and place all thats related to it next to each other with coma delimited

The Youtube one i can actually remove all if needed and have the unique YT no alone in the cells

Any Help is highly helpful

thank you
Macro-Help.xlsx
mtthompsonsAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Saurabh Singh TeotiaCommented:
Their you go..Use the following code...

Sub movedata()
    Dim ws As Worksheet
    Dim ws1 As Worksheet

    Set ws = Sheets("Sheet1")
    Set ws1 = Sheets("Ouput1")

    ws1.Cells.Clear

    Dim cell As Range, lrow As Long, lr As Long
    Dim rng As Range, i As Long
    Dim str As String

    lrow = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    Set rng = ws.Range("C2:C" & lrow)

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            If ws1.Cells(1, 1).Value = "" Then
                lr = 1
            Else
                lr = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
            End If
            cell.Copy
            ws1.Range("A" & lr).PasteSpecial xlPasteValues
            str = ""
            i = cell.Row
            Do Until Trim(ws.Cells(i, "g").Value) = ""

                If str = "" Then
                    str = Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare))
                Else
                    str = str & "," & Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare))
                End If

                i = i + 1

            Loop
            ws1.Range("B" & lr).Value = str

        End If

    Next cell

    ws1.Cells.EntireColumn.AutoFit
End Sub

Open in new window


Enclosed is your macro file for your reference..I have created or showed my output in the sheet name output1 change it basis of your requirements..

Saurabh...
Macro-Help.xlsm
mtthompsonsAuthor Commented:
I get runtime error 7

Out of memory

When i click debug goes here
   str = Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare))

Just first entry shows up
 143 Nooranalavathmuru
Saurabh Singh TeotiaCommented:
Use this code..

Sub movedata()
    Dim ws As Worksheet
    Dim ws1 As Worksheet

    Set ws = Sheets("Sheet1")
    Set ws1 = Sheets("Ouput1")

    ws1.Cells.Clear

    Dim cell As Range, lrow As Long, lr As Long
    Dim rng As Range, i As Long
    Dim str As String

    lrow = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    Set rng = ws.Range("C2:C" & lrow)

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            If ws1.Cells(1, 1).Value = "" Then
                lr = 1
            Else
                lr = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
            End If
            cell.Copy
            ws1.Range("A" & lr).PasteSpecial xlPasteValues
            str = ""
            i = cell.Row
            Do Until Trim(ws.Cells(i, "g").Value) = ""
                If InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare) > 0 Then
                    If str = "" Then
                        str = Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare))
                    Else
                        str = str & "," & Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare))
                    End If
                End If

                i = i + 1

            Loop
            ws1.Range("B" & lr).Value = str

        End If

    Next cell

    ws1.Cells.EntireColumn.AutoFit
End Sub

Open in new window


Saurabh...
PMI ACP® Project Management

Prepare for the PMI Agile Certified Practitioner (PMI-ACP)® exam, which formally recognizes your knowledge of agile principles and your skill with agile techniques.

Start Today!
mtthompsonsAuthor Commented:
Same error

                If InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare) > 0 Then
Saurabh Singh TeotiaCommented:
It runs for me without any problem..Can you post your sample original file where you are running this code..Also did you change the ws name at the starting which is..

Set ws = Sheets("Sheet1")

This to the worksheet name which you want to refer to?? So if you want to refer to sheet5 this will be..

Set ws=Sheet("Sheet")

Saurabh...
mtthompsonsAuthor Commented:
I am actually using the file you attached and in that file i get this issue

I have Excel 2011 for Mac would that be an issue?
Saurabh Singh TeotiaCommented:
Yeah that can be the issue as that feature not available in it..Let me try to change this for you...

Try this one...

Sub movedata()
    Dim ws As Worksheet
    Dim ws1 As Worksheet

    Set ws = Sheets("Sheet1")
    Set ws1 = Sheets("Ouput1")

    ws1.Cells.Clear

    Dim cell As Range, lrow As Long, lr As Long
    Dim rng As Range, i As Long
    Dim str As String

    lrow = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    Set rng = ws.Range("C2:C" & lrow)

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            If ws1.Cells(1, 1).Value = "" Then
                lr = 1
            Else
                lr = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
            End If
            cell.Copy
            ws1.Range("A" & lr).PasteSpecial xlPasteValues
            str = ""
            i = cell.Row
            Do Until Trim(ws.Cells(i, "g").Value) = ""

                If str = "" Then
                    str = Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1))
                Else
                    str = str & "," & Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1))
                End If

                i = i + 1

            Loop
            ws1.Range("B" & lr).Value = str

        End If

    Next cell

    ws1.Cells.EntireColumn.AutoFit
End Sub

Open in new window


Workbook...

Saurabh...
Macro-Help.xlsm
mtthompsonsAuthor Commented:
Now it works for 45 rows and than get the attached error

                    str = Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1))
Screen-Shot-2015-09-15-at-12.47.45-a.png
mtthompsonsAuthor Commented:
It failed on row 11 as attached is it because of N/A

If N/A can we skip and move to next
Screen-Shot-2015-09-15-at-12.49.54-a.png
Saurabh Singh TeotiaCommented:
Use this..

Sub movedata()
    Dim ws As Worksheet
    Dim ws1 As Worksheet

    Set ws = Sheets("Sheet1")
    Set ws1 = Sheets("Ouput1")

    ws1.Cells.Clear

    Dim cell As Range, lrow As Long, lr As Long
    Dim rng As Range, i As Long
    Dim str As String

    lrow = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    Set rng = ws.Range("C2:C" & lrow)

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            If ws1.Cells(1, 1).Value = "" Then
                lr = 1
            Else
                lr = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
            End If
            cell.Copy
            ws1.Range("A" & lr).PasteSpecial xlPasteValues
            str = ""
            i = cell.Row
            Do Until Trim(ws.Cells(i, "g").Value) = ""
                If IsNumeric(Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1)) Then
                    If str = "" Then
                        str = Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1))
                    Else
                        str = str & "," & Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1))
                    End If
                End If

                i = i + 1

            Loop
            ws1.Range("B" & lr).Value = str

        End If

    Next cell

    ws1.Cells.EntireColumn.AutoFit
End Sub

Open in new window


Workbook..

Saurabh...
Macro-Help.xlsm
mtthompsonsAuthor Commented:
I get runtime error 1004

  If IsNumeric(Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1)) Then
             

Screenshot attached
Screen-Shot-2015-09-15-at-12.54.22-a.png
Saurabh Singh TeotiaCommented:
This is because of your mac..Do you get the error in this one too??

Sub movedata()
    Dim ws As Worksheet
    Dim ws1 As Worksheet

    Set ws = Sheets("Sheet1")
    Set ws1 = Sheets("Ouput1")

    ws1.Cells.Clear

    Dim cell As Range, lrow As Long, lr As Long
    Dim rng As Range, i As Long
    Dim str As String

    lrow = ws.Cells(Cells.Rows.Count, "A").End(xlUp).Row

    Set rng = ws.Range("C2:C" & lrow)

    For Each cell In rng
        If Trim(cell.Value) <> "" Then
            If ws1.Cells(1, 1).Value = "" Then
                lr = 1
            Else
                lr = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
            End If
            cell.Copy
            ws1.Range("A" & lr).PasteSpecial xlPasteValues
            str = ""
            i = cell.Row
            Do Until Trim(ws.Cells(i, "g").Value) = ""
                If (Mid(Trim(ws.Cells(i, "g").Value), 31, 1)) = "=" Then
                    If str = "" Then
                        str = Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1))
                    Else
                        str = str & "," & Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1))
                    End If
                End If

                i = i + 1

            Loop
            ws1.Range("B" & lr).Value = str

        End If

    Next cell

    ws1.Cells.EntireColumn.AutoFit
End Sub

Open in new window


Workbook..

Saurabh..
Macro-Help.xlsm
mtthompsonsAuthor Commented:
str = Right(ws.Cells(i, "g").Value, Len(ws.Cells(i, "g").Value) - Application.WorksheetFunction.Find("=", ws.Cells(i, "g").Value, 1))


I get this now
Screen-Shot-2015-09-15-at-1.03.08-am.png
Saurabh Singh TeotiaCommented:
I'm not sure why you are getting this error now..Can you post the line where it gives you an error..or post your revised workbook..?? Or you can try in windows
mtthompsonsAuthor Commented:
Code from : ID: 40976946

Works fine on Windows but as attached some wrong data is picked...

Where N/A the data from next fields is captured and becomes duplicate
File.JPG
mtthompsonsAuthor Commented:
Another issue is some places content is as attached

In such cases the data is Outputted as below

 Vascodigama       kx7tWqxKzR8 ,J2ICRG9Et2A ,b62gI1T--Gg ,SEKMaBpxoDs
File.JPG
mtthompsonsAuthor Commented:
Hi Saurabh any luck...
Saurabh Singh TeotiaCommented:
mtthompsons,

Can you give me your revised file where the data looks like this and where you see it's failing..so that i can look over the same and can check and confirm..

Saurabh...
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
I think I have joined late here.
Please try the below code and see if you have any luck with this....

Sub mtthompsons()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long, i As Long
Dim rng As Range, cell As Range
Dim sName As String, str() As String

Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
Set dws = Sheets("Output")
lr = sws.Cells(Rows.Count, "G").End(xlUp).Row
Set rng = sws.Range("G2:G" & lr)
dws.Cells.Clear
For Each cell In rng
    If Trim(sws.Cells(cell.Row, "A")) <> "" Then
        sName = Trim(sws.Cells(cell.Row, "C"))
        If dws.Range("A1").Value = "" Then
            dws.Range("A1").Value = sName
        Else
            dws.Range("A" & Rows.Count).End(3)(2).Value = sName
        End If
        str() = Split(cell, "=")
        If UBound(str()) <> 0 Then
            If dws.Range("B" & dws.Range("A" & Rows.Count).End(3).Row).Value = "" Then
                dws.Range("B" & dws.Range("A" & Rows.Count).End(3).Row).Value = Trim(str(1))
            Else
                dws.Range("B" & dws.Range("A" & Rows.Count).End(3).Row).Value = dws.Range("B" & dws.Range("A" & Rows.Count).End(3).Row).Value & "," & Trim(str(1))
            End If
        End If
    ElseIf Trim(cell) <> "" Then
        str() = Split(cell, "=")
        If UBound(str) <> 0 Then
            If dws.Range("B" & dws.Range("A" & Rows.Count).End(3).Row).Value = "" Then
                dws.Range("B" & dws.Range("A" & Rows.Count).End(3).Row).Value = str(1)
            Else
                dws.Range("B" & dws.Range("A" & Rows.Count).End(3).Row).Value = dws.Range("B" & dws.Range("A" & Rows.Count).End(3).Row).Value & "," & str(1)
            End If
        End If
    End If
    Erase str
Next cell
dws.Activate
Application.ScreenUpdating = True
MsgBox "Done!", vbInformation
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.