VBA to merge rows, below and above an specific cell value within the same column

[krsk92]

Hi there

I am new with VBA and I am trying to develop an excel macro for this topic, but I haven´t been able to find something that would meet my needs as a starting point, hence I am looking for some help to develop an excel macro that will merge rows, below and above an specific cell value within the same column

For example, I have the following set of data in column A:

A1-->Position name
A2-->Company name
A3-->Requeriments
A4-->AAAAA
A5-->BBBBB
A6-->CCCCC
A7-->Skills
A8-->XXXX
A9-->YYYY

The macro should look for the values in column A, and merge starting with the cell that contains "Requirements" and would finish above the cell that contains "Skills", as shown below:
A1-->Position name
A2-->Company name
A3-->Requeriments
AAAAA
BBBBB
CCCCC
A4-->Skills
XXXX
YYYY

Then the macro would loop through the other columns and do the same. Note that the other columns can have more rows of data that would need to be merged under requirements and skills.

Please let me know if you have any doubts, any help would be greatly appreciated!!

Regards,

 

[Yongle]

Test on a COPY of your worksheet
- VBA finds Requirements (not Requeriments) which I assume was a typo in your OP
- code below assumes Requirements and Skills can be found in EVERY column and that Requirements is ALWAYS in row 3


Excel 2016 (Windows) 32 bit

	A​	B​	C​
1​	Director	Consultant	Marketeer
2​	Company A	Company B	Company C
3​	Requirements	Requirements	Requirements
4​	A	A	A
5​	B	B	B
6​	C	C	C
7​	Skills	D	D
8​	X	E	E
9​	Y	F	Skills
10​		G	X
11​		H	Y
12​		Skills	Z
13​		X
14​		Y

Sheet: Before

Excel 2016 (Windows) 32 bit

	A​	B​	C​
1​	Director	Consultant	Marketeer
2​	Company A	Company B	Company C
3​	Requirements A B C	Requirements A B C D E F G H	Requirements A B C D E
4​	Skills X Y	Skills X Y	Skills X Y Z

Sheet: After

Sub MergeCellValues()
    Dim lastCell As Range, Require As Range, Skills As Range, cel As Range
    Dim R As String, S As String, c As Long
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.VerticalAlignment = xlTop

    For c = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
        Set lastCell = Cells(Rows.Count, c).End(xlUp)
        Set Require = Columns(c).Find("Requirements", lookat:=xlWhole)
        Set Skills = Columns(c).Find("Skills", lookat:=xlWhole)
    
[COLOR=#006400]'string for requirements[/COLOR]
        For Each cel In Range(Require, Skills.Offset(-1))
            R = R & cel & Chr(10)
        Next
        Require = Left(R, Len(R) - 1)
[COLOR=#006400]'string for skills[/COLOR]
        For Each cel In Range(Skills, lastCell)
            S = S & cel & Chr(10)
        Next
        Require.Offset(1) = Left(S, Len(S) - 1)
        
        R = "": S = ""
    Next c

[COLOR=#006400]'clear rows 5 onwards[/COLOR]
    Cells(5, 1).Resize(Rows.Count - 4).EntireRow.Delete

End Sub

 

[krsk92]

Works great, thank you very much for your help!