PDA

View Full Version : Split cells data in below rows with other data.



diepak
03-09-2018, 04:26 AM
Hello Everyone,

I have attached a file, In column no. H (Emails), I have Multiple emails in most of the cells. So I need to split them in rows but other data should be copied as it is in front of every row.
For E.G.
Row no. A2 has two emails in H2, so there should be two rows only. Other data should be copy/pasted as normal, only emails need to split with same other data.
Row no. A3 has twenty emails so there should be twenty rows and so on....

Please see file if this can be done ?

Thanks !!

georgiboy
03-09-2018, 07:50 AM
There may be faster ways of doing this but i assumed you wanted to keep all of the formatting as is so i copied a row.

Here is the code, it takes the data from Sheet1 and places it on Sheet2:
You would need to remove your example rows from the bottom of your data.


Sub SplitMail()
Dim rCell As Range, mVar() As String
Dim MailRng As Range, pRng As Range

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With Sheet1
Set MailRng = .Range("H2:H" & .Range("H" & Rows.Count).End(xlUp).Row)

For Each rCell In MailRng.Cells
If Right(rCell.Value, 1) = ";" Then
rCell.Value = Left(rCell.Value, Len(rCell.Value) - 1)
End If
mVar = Split(rCell.Value, ";")
Set pRng = Sheet2.Range("A" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1)
rCell.EntireRow.Copy
Sheet2.Range(pRng, pRng.Offset(UBound(mVar))).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Sheet2.Range(pRng.Offset(, 7), pRng.Offset(UBound(mVar), 7)) = _
Application.Transpose(mVar)
Next rCell
End With

With Application
.ScreenUpdating = False
.Calculation = xlCalculationAutomatic
End With

End Sub

diepak
03-12-2018, 03:43 AM
Thank you so so much buddy !!!