Macro for Extracting content of Cells containing multiple lines

Michelle_112

New Member
Joined
May 6, 2010
Messages
40
hi All,

I have a tracking spreadsheet that tracks status progress of about 50 different procedures manuals.
There is a procedures manual, per row with various related columns for each manual. One of the columns is an 'Action status' column - which is updated on a daily basis for each manual.
(Alt+ enter) function is used to insert a 'new line within the 'Action status cell for each manual, for each days given update
eg. though 1 x status comment could go for > x1 line (within the same cell). Majority of the updates are sequential - format of dates like example below.

My Objective is to:
Develop a report via macro that will show only the last couple of dates worth of udpates for each manual. Eg. I want to extract data from the last 1-2 lines in the 'Action status column' . Eg. being wording " 24/01 - Last update (example) " Cell range: C2 --> C11.
( Please refer to attached s/s which shows what im talking about.)

Not sure if this could work? Thought about some possible options:

Eg1.
Migrating the data - extracting data from the last 1-2 lines in the 'Action status column' cells containing multiple lines
ie. 'Migrate data' from "Column C's" latest update. Eg. being wording " 24/01 - Last update (example) " in Columns Cell range: C2 --> C11.
1) into a new column in the existing sheet. (next to the action status column)

OR
Eg2.
Migrate data' from "Column C's" latest update (1-2 lines within each cell) . Eg. being wording " 24/01 - Last update (example) " into a separate sheet with Column the same 3 related columns (just minus the old updates history)
Note: Format on my actual sheet has the same date format.
eg.
24/03 - xxxx
25/03 - xxxx
26/03 etc.

Eg3.
Rather than migrate the data - somehow delete all "All updates within each cell in column C, except for the last 1-2 Lines.

At the moment Im spending hours deleting old updates & creating new versions of spreadsheets - as I need to keep the historical content, but is not useful to me on a daily basis, espec. with reporting on current status.

Not sure if its possible?:confused: Anyone have any ideas would really appreciate it.
Excel Workbook
ABC
1Procedure manual nameProcedure manual #Action Status
2Procedure manual APM#113/01 - First update (example)14/01 - update xyz 15/01 - update xyz 16/01 - update xyz 17/01 - update xyz 18/01 - update xyz 19/01 - update xyz 22/01 - update xyz 23/01 - update xyz 24/01 - Last update (example)
3Procedure manual BPM#213/01 - First update (example)14/01 - update xyz 15/01 - update xyz 16/01 - update xyz 17/01 - update xyz 18/01 - update xyz 19/01 - update xyz 22/01 - update xyz 23/01 - update xyz 24/01 - Last update (example)
4Procedure manual CPM#313/01 - First update (example)14/01 - update xyz 15/01 - update xyz 16/01 - update xyz 17/01 - update xyz 18/01 - update xyz 19/01 - update xyz 22/01 - update xyz 23/01 - update xyz 24/01 - Last update (example)
5Procedure manual DPM#413/01 - First update (example)14/01 - update xyz 15/01 - update xyz 16/01 - update xyz 17/01 - update xyz 18/01 - update xyz 19/01 - update xyz 22/01 - update xyz 23/01 - update xyz 24/01 - Last update (example)
6Procedure manual EPM#5" "
7Procedure manual APM#6" "
8Procedure manual BPM#7" "
9Procedure manual CPM#8" "
10Procedure manual DPM#9" "
11Procedure manual EPM#10" "
Sheet1
 

Some videos you may like

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)

bertie

Well-known Member
Joined
Jun 12, 2009
Messages
1,869
What the code below does is split the contents of each cell in column C into an array based on the carriage return character, chr(10).

If this doesn't work try changing this to chr(13) - end of line, or vbCrLf.

Code:
      [COLOR=green]'split the text on carriage return character chr(10)[/COLOR]
      aText = Split(rng.Value, [COLOR=blue]Chr(10[/COLOR]))

It then finds the upper bound of the array and builds up a text string for output. I have used the last three lines to make it easier to read

Code:
      [COLOR=green]'get the number of array elements[/COLOR]
      i = [COLOR=darkblue]UBound[/COLOR](aText)
 
      [COLOR=green]'build the output text string[/COLOR]
      sText = aText([COLOR=red]i - 2[/COLOR]) & [COLOR=blue]Chr(10)[/COLOR] _
              & aText([COLOR=red]i - 1[/COLOR]) & [COLOR=blue]Chr(10)[/COLOR] _
              & aText([COLOR=red]i[/COLOR])

It then outputs the text string to column D


One option is to delete the old Column C. I have commented out this line for testing
Code:
[COLOR=seagreen]'==========[/COLOR]
[COLOR=seagreen]'optional[/COLOR]
[COLOR=seagreen]'==========[/COLOR]
[COLOR=seagreen]'Sheets("Sheet1").Columns("C:C").Delete Shift:=xlToLeft[/COLOR]

The full code is below. Make a copy of your workbook for testing
Press Alt+F11
Double click the ThisWorkbook module in the Project Window on the left hand side.
Copy and paste the code.
Edit the name of the worksheet.
Press F5 to run.

Code:
[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]
 
[COLOR=darkblue]Sub[/COLOR] Extract()
   [COLOR=darkblue]Dim[/COLOR] rng [COLOR=darkblue]As[/COLOR] Range
   [COLOR=darkblue]Dim[/COLOR] sText [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] aText [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR] [COLOR=green]'array[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]        'number of array elements
 
   [COLOR=darkblue]Set[/COLOR] rng = Sheets("[COLOR=red]Sheet1[/COLOR]").Range("C2")
 
   [COLOR=darkblue]Do[/COLOR] [COLOR=darkblue]Until[/COLOR] rng = ""
 
      [COLOR=green]'split the text on carriage return character chr(10)[/COLOR]
      aText = Split(rng.Value, Chr(10))
 
      [COLOR=green]'get the number of array elements[/COLOR]
      i = [COLOR=darkblue]UBound[/COLOR](aText)
 
      [COLOR=green]'build the output text string[/COLOR]
      sText = aText(i - 2) & Chr(10) _
              & aText(i - 1) & Chr(10) _
              & aText(i)
 
      [COLOR=green]'output[/COLOR]
      rng.Offset(, 1) = sText
 
      [COLOR=darkblue]Set[/COLOR] rng = rng.Offset(1, 0)
   [COLOR=darkblue]Loop[/COLOR]
 
   [COLOR=green]'==========[/COLOR]
   'optional
   [COLOR=green]'==========[/COLOR]
   'Sheets("Sheet1").Columns("C:C").Delete Shift:=xlToLeft
 
   [COLOR=darkblue]Set[/COLOR] rng = [COLOR=darkblue]Nothing[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
 

Michelle_112

New Member
Joined
May 6, 2010
Messages
40
Thats brilliant! Thank you Bertie :)

I loaded it up, had a played around and is currently working great. Thank you - you've saved me hours of monotonous manual work with this s/s now :)
 

Michelle_112

New Member
Joined
May 6, 2010
Messages
40
Sorry for double post - just to elaborate on the above post. ( i got a bit excited and posted straight away) :LOL:
I loaded it up on my test spreadsheet, had a played around and is currently working great. Seems like you've already saved me hours of monotonous manual work :)

When I get to work this morning Im going to load into my actual spreadsheet with 'real data', change the ranges etc & give it a go. Will let you know how it goes. Thanks for the fast reply also, much appreciated Bertie. Cheers!
 

Watch MrExcel Video

Forum statistics

Threads
1,109,158
Messages
5,527,137
Members
409,749
Latest member
esmarques

This Week's Hot Topics

Top