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

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
1,900
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,214
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]
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,106,545
Messages
5,511,962
Members
408,871
Latest member
Usman21

This Week's Hot Topics

  • Sort code advice please
    Hi, I have the code below which im trying to edit but getting a little stuck. This was the original code which worked fine,columns A-F would sort...
  • SUMPRODUCT with nested If statement
    Hi everyone, Hope you're all well. I'm hoping someone will be able to point me in the right direction with a problem I'm having with a SUMPRODUCT...
  • VBA - simple sort is killing me!
    Hello all! This should be so easy, but not for me, apparently! I have a table of data that can be of varying lengths and widths. My current macro...
  • Compare Two Lists
    I have two Lists and I need to be able to Identify differences between them. List 100 comes from a workbook - the other is downloaded form the...
  • Formula that deducts points for each code I input.
    I am trying to create a formula that will have each student in my class start at 100 points and then for each code that I enter (PP for Poor...
  • Conditional formatting formula required for day of week and a value
    Hi, I have a really simple spreadsheet where column A is the date, column B is the activity total shown as a number and column C states the day of...
Top