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