how to combine relevant bold data from 2 or more cells into one 1

[jlks90]

Hi All

So i need a macro that locates the bold data that come right after each other from a column ("D")
then combines them in the cell next to them in column "C" and it keeps doing it for the next set of bold data that come right after each other

here is what it should do

before:

C D
acura
rdx
4 wheels


toyota
corolla
4 wheels
2000 HD diesel


calibre
van
4 wheels


after:


C D
acura rdx acura
acura rdx rdx
acura rdx 4 wheels


toyota corolla toyota
toyota corolla corolla
toyota corolla 4 wheels
toyota corolla 2000 hd diesel


calibre van calibre
calibre van van
calibre van 4 wheels




so basically it has to concatenate only the bold data that is relevant for each non-bold data...so here the first relevant data for the "4 wheels" is acura rdx

when it reaches the blank rows it stops...

goes to the next set of data...concatenates the bold data again which is toyota corolla and pastes it next to the unbold data "4-wheels" and "2000 hd diesel"

and again for the calibre van


right now I have this code working (thanks to SkipVought)

Sub test()
Dim rng As Range, r As Range, sOUT As String
Set rng = Intersect(Cells(12, "D").EntireColumn, ActiveSheet.UsedRange)
For Each r In rng
    With r
         If .Font.Bold Then
            sOUT = sOUT & .Value & " "
        End If
    End With
Next
sOUT = Left(sOUT, Len(sOUT) - 1)
For Each r In rng
    With r
        If .Font.Bold Then
            With .Offset(0, -1)
                .Value = sOUT
                .Font.Bold = True
            End With
        End If
    End With
Next
Set rng = Nothing
End Sub

however it is taking ALL the bold data and putting them together in the cells in column C...and i need it to pick up only the ones relevant to each group

i already have a macro that will clear the rows which won't be necessary... like


acura rdx acura
acura rdx rdx

toyota corolla toyota
toyota corolla corolla

calibre van calibre
calibre van van




thanks in advance for your help

 

[SkipVought]

hi,

try this, pasted into a module...

Sub MAIN()
    Dim rng As Range, r As Range
    
    Set rng = Intersect(Cells(1, "D").EntireColumn, ActiveSheet.UsedRange)

    Set r = rng.Cells(1, 1).CurrentRegion
    
    Do While r.Count > 1
        ProcessRange r
        
        Set r = r.End(xlDown).End(xlDown).CurrentRegion
    Loop
End Sub

Sub ProcessRange(rng As Range)
    Dim r As Range, sOUT As String
    
    For Each r In rng
        With r
             If .Font.Bold Then
                sOUT = sOUT & .Value & " "
            End If
        End With
    Next
    sOUT = Left(sOUT, Len(sOUT) - 1)
    For Each r In rng
        With r
            If .Font.Bold Then
                With .Offset(0, -1)
                    .Value = sOUT
                    .Font.Bold = True
                End With
            End If
        End With
    Next
End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[jlks90]

I tried the new code on a new excel sheet with the same data...however it does not do anything

it doesn't say errors or anything...the sheet just stays the same

when I click on macros the title is "MAIN"
I select that and click run...but it doesn't work

 

[SkipVought]

Exactly where did your paste the code?

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[jlks90]

oh nevermind it works now...i recopied and pasted your code again...and changed

Set r = rng.Cells(1, 1).CurrentRegion

to

Set r = rng.Cells(12, 1).CurrentRegion

because the first cell to which it applies shows up on row 12


Just one little thing...it does not paste the bold data next to the unbold one

what it does right now is


before:


C D
acura
rdx
4 wheels


toyota
corolla
4 wheels
2000 HD diesel


calibre
van
4 wheels


after:


C D
acura rdx acura
acura rdx rdx
4 wheels


toyota corolla toyota
toyota corolla corolla
4 wheels
2000 hd diesel


calibre van calibre
calibre van van
4 wheels




so it does pick up the correct data and pastes it in the correct column...but it does not paste it besides the "D" cells where the data is NOT bold like "4 wheels"

i needed it to end up like this


C D
acura rdx acura
acura rdx rdx
acura rdx 4 wheels


toyota corolla toyota
toyota corolla corolla
toyota corolla 4 wheels
toyota corolla 2000 hd diesel


calibre van calibre
calibre van van
calibre van 4 wheels


and I noticed that it does not work for the whole sheet...right now the macro stops working at row 245 and the last row with data in it is 2516

 

[SkipVought]

that should have been row 1, column D

Set rng = Intersect(Cells(1, "D").EntireColumn, ActiveSheet.UsedRange)

Does EVERY group have at least one BOLD?

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[jlks90]

Yes they do...

after going over the sheet again and again i think i know where the problem is...im not too sure but some of the data in the groups are not contiguous so they are like this

C D
Multi-purpose vehicle

van
LT

and that's where the macro stopped
is that the reason why the macro stopped?
and should i just delete those empty rows to make them contiguous?
I did not notice that before I thought they were all contiguous

 

[SkipVought]

this
[tt]
C D
Multi-purpose vehicle

van
LT

[/tt]
should become this
[tt]
C D
Multi-purpose vehicle Multi-purpose vehicle

van van
LT

[/tt]

Sub ProcessRange(rng As Range)
    Dim r As Range, sOUT As String
    
    For Each r In rng
        With r
             If .Font.Bold Then
                sOUT = sOUT & .Value & " "
            End If
        End With
    Next
    sOUT = Left(sOUT, Len(sOUT) - 1)
    For Each r In rng
        With r
                With .Offset(0, -1)
                    .Value = sOUT
                    .Font.Bold = True
                End With
        End With
    Next
End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[jlks90]

thanks!! it is now pasting in cells next to unbold ones...

but concerning the groups that are not contiguous...you're almost right

this

C D
multi-purpose vehicle

van
LT

should end up like this


C D
multi-purpose vehicle van multi-purpose vehicle

multi-purpose vehicle van van
multi-purpose vehicle van LT

 

[SkipVought]

It is not contiguous! Why is the empty wor in ther???

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[SkipVought]

sorry, Why is the empty row in there?

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[jlks90]

Honestly I dont know why they do that...I am only working with the data I am given...

I have a macro that deletes empty rows so I'll try that to make the groups contiguous and then use the code you gave me...I'll post any progress made so that others can use it

 

[jlks90]

I meant: I dont know why they put the empty row there

 

[SkipVought]

I do not understand.

First you said, regarding my solution, "you're almost right"

Then you stated, "I dont know why they put the empty row there"

So is the code not working according to the stated requirement?

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[jlks90]

what i meant by "your almost right" is that you wrote:

this

C D
multi-purpose

van
LT

should become

C D
multi-purpose multi-purpose

van van
LT


but i wanted it to be like is this


C D
multi-purpose van multi-purpose

multi-purpose van van
multi-purpose van LT


Regards to the existence of the empty row is that the data gets automatically populated including the empty row.
The empty row was not created nor purposely done so, but due to the arrangements from the original data, Excel recognizes the empty row and creates it automatically.

Hence, is there a way to create a macro that recognizes the empty row as well with the bolded fields and gets pasted accordingly as shown above?

I hope this is more clear. If you are still confused, let me know and I will try my best to describe it thoroughly.

 

[SkipVought]

Suppose you state, for me, the LOGIC, that would accomplish that.

I have already incorporated the logic that you have formerly specified.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}