Split by macros

[Iamsuyog]

Dear all

[TABLE="width: 500, align: center"]
<tbody>[TR]
[TD]Case number[/TD]
[TD]country[/TD]
[TD]report type[/TD]
[TD]Events/PT term (column D)[/TD]
[/TR]
[TR]
[TD]2223-055684[/TD]
[TD]INDIA[/TD]
[TD]study / interventional study[/TD]
[TD]1) Atrial septal defect (foramen secundum) / Atrial septal defect (s);[/TD]
[/TR]
[TR]
[TD]2222-032943[/TD]
[TD]US[/TD]
[TD]spontaneous / --[/TD]
[TD]1) face redness / Erythema ;
2) felt hot / Feeling hot ;
3) felt faint / Dizziness ;
4) dizziness / Dizziness ;
5) hands and feet weakness / Muscular weakness ;
6) arterial pressure increased to 140/70mmHg / Blood pressure systolic increased ;
7) flushes / Flushing ;
[/TD]
[/TR]
</tbody>[/TABLE]





i want to spilt multiple rows of the column D (Events/PT term) in to separate rows with the rest column contents same and count the unique cases and total rows may be at the top of your output excel. Also highlight rows in alternate color for better readability.

 

[ranman256]

try:

Option Explicit
Sub SplitCell()
Dim vCase, vTyp, vCountry, vEvent, vWord
Dim i As Integer
Dim shtSrc As Worksheet, shtTarg As Worksheet


'On Error Resume Next


Set shtSrc = ActiveSheet
Sheets.Add
Set shtTarg = ActiveSheet
Range("A1").Value = "Case"
Range("b1").Value = "Country"
Range("c1").Value = "Report Type"
Range("d1").Value = "Events"
Range("a2").Select
shtSrc.Activate


Range("A2").Select
While ActiveCell.Value <> ""
   vCase = ActiveCell.Offset(0, 0).Value
   vCountry = ActiveCell.Offset(0, 1).Value
   vTyp = ActiveCell.Offset(0, 2).Value
   vWord = ActiveCell.Offset(0, 3).Value
   
   i = InStr(vWord, ";")
   While i > 0
     If i = Len(vWord) Then
       vEvent = vWord
       vWord = ""
     Else
       vEvent = Left(vWord, i)
       vWord = Mid(vWord, i + 1)
     End If
     
      GoSub PostRec
      i = InStr(vWord, ";")
   Wend
   
   ActiveCell.Offset(1, 0).Select   'next row
Wend


shtTarg.Activate
Set shtSrc = Nothing
Set shtTarg = Nothing
MsgBox "Done"
Exit Sub


PostRec:
shtTarg.Activate
 ActiveCell.Offset(0, 0).Value = vCase
 ActiveCell.Offset(0, 1).Value = vCountry
 ActiveCell.Offset(0, 2).Value = vTyp
 ActiveCell.Offset(0, 3).Value = vEvent
 
 ActiveCell.Offset(1, 0).Select   'next row
shtSrc.Activate
Return
End Sub

 

[Rick Rothstein]

Here is another macro that you can consider...

[table="width: 500"]
[tr]
	[td]Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
  Const Delimiter As String = vbLf
  Const DelimitedColumn As String = "D"
  Const TableColumns As String = "A:D"
  Const StartRow As Long = 2
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  For X = LastRow To StartRow Step -1
    Data = Split(Cells(X, DelimitedColumn), Delimiter)
    If UBound(Data) > 0 Then
      Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
    End If
    If Len(Cells(X, DelimitedColumn)) Then
      Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]