Avatar of mtthompsons
mtthompsons
 asked on

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
Microsoft Excel

Avatar of undefined
Last Comment
Subodh Tiwari (Neeraj)

8/22/2022 - Mon
SOLUTION
Saurabh Singh Teotia

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
GET A PERSONALIZED SOLUTION
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.
mtthompsons

ASKER
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 Teotia

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...
mtthompsons

ASKER
Same error

                If InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare) > 0 Then
Experts Exchange has (a) saved my job multiple times, (b) saved me hours, days, and even weeks of work, and often (c) makes me look like a superhero! This place is MAGIC!
Walt Forbes
Saurabh Singh Teotia

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...
mtthompsons

ASKER
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 Teotia

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
⚡ FREE TRIAL OFFER
Try out a week of full access for free.
Find out why thousands trust the EE community with their toughest problems.
mtthompsons

ASKER
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
mtthompsons

ASKER
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 Teotia

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
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
mtthompsons

ASKER
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 Teotia

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
mtthompsons

ASKER
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
⚡ FREE TRIAL OFFER
Try out a week of full access for free.
Find out why thousands trust the EE community with their toughest problems.
Saurabh Singh Teotia

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
mtthompsons

ASKER
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
mtthompsons

ASKER
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
All of life is about relationships, and EE has made a viirtual community a real community. It lifts everyone's boat
William Peck
mtthompsons

ASKER
Hi Saurabh any luck...
Saurabh Singh Teotia

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...
ASKER CERTIFIED SOLUTION
Subodh Tiwari (Neeraj)

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
GET A PERSONALIZED SOLUTION
Ask your own question & get feedback from real experts
Find out why thousands trust the EE community with their toughest problems.