Split by macros

Iamsuyog

New Member
Joined
May 22, 2017
Messages
32
Dear all

Case numbercountryreport typeEvents/PT term (column D)
2223-055684INDIAstudy / interventional study1) Atrial septal defect (foramen secundum) / Atrial septal defect (s);
2222-032943USspontaneous / --1) face redness / Erythema (n);
2) felt hot / Feeling hot (n);
3) felt faint / Dizziness (n);
4) dizziness / Dizziness (n);
5) hands and feet weakness / Muscular weakness (n);
6) arterial pressure increased to 140/70mmHg / Blood pressure systolic increased (n);
7) flushes / Flushing (n);

<tbody>
</tbody>





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.
 

Some videos you may like

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
1,895
try:

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

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,039
Office Version
2010
Platform
Windows
Here is another macro that you can consider...
Code:
[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]
 

Watch MrExcel Video

Forum statistics

Threads
1,102,362
Messages
5,486,395
Members
407,544
Latest member
mguevara

This Week's Hot Topics

Top