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

mtthompsons
mtthompsons used Ask the Experts™
on
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
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2015
Commented:
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

Author

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
Top Expert 2015

Commented:
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...
Become a Microsoft Certified Solutions Expert

This course teaches how to install and configure Windows Server 2012 R2.  It is the first step on your path to becoming a Microsoft Certified Solutions Expert (MCSE).

Author

Commented:
Same error

                If InStr(1, ws.Cells(i, "g").Value, "=", vbTextCompare) > 0 Then
Top Expert 2015

Commented:
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...

Author

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?
Top Expert 2015

Commented:
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

Author

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

Author

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
Top Expert 2015

Commented:
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

Author

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
Top Expert 2015

Commented:
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

Author

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
Top Expert 2015

Commented:
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

Author

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

Author

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

Author

Commented:
Hi Saurabh any luck...
Top Expert 2015

Commented:
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...
Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015
Commented:
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

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial