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

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

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

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

Saurabh...

ASKER

Same error

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

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

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?

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

Workbook...

Saurabh...
Macro-Help.xlsm

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

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

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

Workbook..

Saurabh...
Macro-Help.xlsm

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

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

Workbook..

Saurabh..
Macro-Help.xlsm

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

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

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

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

ASKER

Hi Saurabh any luck...