Need macro to copy specific text in one column to a different column

[skyport]

Hopefully someone can help with this one. I have paragraphs of text that are spread out between multiple cells in one column, which is column A. Each cell in column A could have anywhere from one to numerous separate paragraphs. Each paragraph is separated with a blank line. The first words in each paragraph begin with a headline of words that are in bold followed the rest of the paragraph, which is not in bold except for occasional random word somewhere further into the paragraph. What I need to be able to do is have a macro or solution that will take each paragraph and select only the first words in each paragraph that are in bold, which is the headline, before the text in each paragraph changes to being not bolded and then place that bolded sentence of each paragraph in a separate cell in column B. The random words in bold within the paragraph that are not part of the headline should be ignored. The idea is to create a list in column B of just those headlines that are in bold from each paragraph with each headline being in its own separate cell in column B. Please help if you can.

 

[sijpie]

Read the comments in the first macro to see how to use.



<font face=Calibri><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN><br><br><SPAN style="color:#00007F">Sub</SPAN> ExtractHeadingsFromCurrentColumn()<br><SPAN style="color:#007F00">' Run down the current column and extract _<br>  bold headers from each paragraph in each _<br>  cell. The headers are placed in column B.</SPAN><br><br>    <SPAN style="color:#00007F">Dim</SPAN> lRLast <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, lR <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, lC <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    lC = ActiveCell.Column<br>    lRLast = Cells(Rows.Count, lC).End(xlUp).Row<br>    <br>    <SPAN style="color:#00007F">For</SPAN> lR = 1 <SPAN style="color:#00007F">To</SPAN> lRLast<br>        SplitCellinPara Cells(lR, lC), Columns("B").Column<br>    <SPAN style="color:#00007F">Next</SPAN> lR<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> SplitCellinPara(rCheck <SPAN style="color:#00007F">As</SPAN> Range, lColOutp <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>)<br><SPAN style="color:#007F00">' Split the text in each cell in paragraphs (separated _<br>  by two LineFeeds (2x Alt+Enter))and get the bold heading _<br>  (if exists) for each paragraph. Put the heading _<br>  in the next available cell in column lColOutp</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> lP <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> sHead <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <br>    lP = 0<br>    <SPAN style="color:#00007F">If</SPAN> rCheck.Value <> vbNullString <SPAN style="color:#00007F">Then</SPAN><br>        <SPAN style="color:#00007F">Do</SPAN><br>            sHead = getBold(rCheck, lP + 1)<br>            PutHeading lColOutp, sHead<br>            lP = InStr(lP + 1, rCheck, vbLf & vbLf) + 1<br>        <SPAN style="color:#00007F">Loop</SPAN> <SPAN style="color:#00007F">While</SPAN> lP > 1<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> getBold(rPar <SPAN style="color:#00007F">As</SPAN> Range, <SPAN style="color:#00007F">ByVal</SPAN> lStart <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#007F00">' Return any bold text at start of text in rPar starting at character lStart</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> lSpace <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, lBold <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, lLen <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    lSpace = lStart<br>    <SPAN style="color:#00007F">Do</SPAN><br>        lBold = lSpace<br>        lSpace = InStr(lSpace + 1, rPar, " ")<br>    <SPAN style="color:#00007F">Loop</SPAN> <SPAN style="color:#00007F">While</SPAN> rPar.Characters(Start:=lStart, Length:=lSpace - lStart).Font.Bold<br>    lBold = lBold - 1<br>    <SPAN style="color:#00007F">If</SPAN> lBold > lStart <SPAN style="color:#00007F">Then</SPAN><br>        getBold = Mid(rPar, lStart, lBold - lStart + 1)<br>    <SPAN style="color:#00007F">Else</SPAN><br>        getBold = vbNullString<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> PutHeading(<SPAN style="color:#00007F">ByVal</SPAN> lColNum <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, sHeading <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>)<br><SPAN style="color:#007F00">' Enter the heading string into the next cell in column lColNum</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> lRow <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    lRow = Cells(Rows.Count, lColNum).End(xlUp).Row + 1<br>    Cells(lRow, lColNum).Value = sHeading<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>



Paste all this code in a VBA macro module. If you need help with that let me know

 

[sijpie]

Instructions. Place your cell in the column where the headers are (i think in column A in your case). Then press ALt-F8 to open the macro dialog and select the macro to run.

 

[skyport]

Thanks for helping me. I followed instructions and nothing showed up as results.

 

[sijpie]

OK, quick checklist:

1. You have copied the macro into a macro module in this workbook. (If not, in Excel with your workbook open, press Alt-F11 to open the VBA editor. To the left you will see your workbook. Right click on the workbook name and select 'Insert / Module'. In the module that opens to the right, paste the macro.
2. You have saved the workbook as .xlsm (because it now contains a macro).
3. You are on the sheet with the text from which you want to extract the headers
4. Column B is empty (apart from a header perhaps)(It doesn't need to be empty, anything will be placed below the last entry, but if it is empty it is easier to check the macro is working)
5. You have selected a cell in the column with the text and headers.
6. Press Alt-F8. The macro dialogbox comes up
7. It shows a macro: ExtractHeadingsFromCurrentColumn
8. You select it and press the run button (or just double click it)
9. Nothing seemed to happen

If the above is the case, go to the VBA and replace only the ExtractHeadingsFromCurrentColumn macro with the following. I have added one line which will tell us what range has been processed, so you can check if that was correct.

<font face=Calibri><SPAN style="color:#00007F">Sub</SPAN> ExtractHeadingsFromCurrentColumn()<br><SPAN style="color:#007F00">' Run down the current column and extract _<br>  bold headers from each paragraph in each _<br>  cell. The headers are placed in column B.</SPAN><br><br>    <SPAN style="color:#00007F">Dim</SPAN> lRLast <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, lR <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, lC <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    lC = ActiveCell.Column<br>    lRLast = Cells(Rows.Count, lC).End(xlUp).Row<br>    <br>    <SPAN style="color:#00007F">For</SPAN> lR = 1 <SPAN style="color:#00007F">To</SPAN> lRLast<br>        SplitCellinPara Cells(lR, lC), Columns("B").Column<br>    <SPAN style="color:#00007F">Next</SPAN> lR<br>    MsgBox "Processed " & lRLast & " cells in the range " & Intersect(Range("1:" & lRLast), ActiveCell.EntireColumn).Address<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>