Macro for Extracting content of Cells containing multiple lines

[Michelle_112]

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? Anyone have any ideas would really appreciate it.

Excel Workbook
	A	B	C
1	Procedure manual name	Procedure manual #	Action Status
2	Procedure manual A	PM#1	13/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)
3	Procedure manual B	PM#2	13/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)
4	Procedure manual C	PM#3	13/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)
5	Procedure manual D	PM#4	13/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)
6	Procedure manual E	PM#5	" "
7	Procedure manual A	PM#6	" "
8	Procedure manual B	PM#7	" "
9	Procedure manual C	PM#8	" "
10	Procedure manual D	PM#9	" "
11	Procedure manual E	PM#10	" "
Sheet1

 

[bertie]

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.

      [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

      [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

[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.

[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]

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]

Sorry for double post - just to elaborate on the above post. ( i got a bit excited and posted straight away)
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!