How do I merge rows individually that are between borders using Excel VBA? - excel

Question

I have a task that I'd like to automate for an excel file I have which is very big. I can't seem to find some proper examples as i never worked with VBA. I need to do something like this For each row i need to do this for whatever text is between the thick border.
Sorry if i am not clear enough.

Answer 1

Please, test the next code:
Sub testDetermineThickBorder()
Dim sh As Worksheet, cel As Range, rngB As Range, lastR As Long, lastC As Long, strSep As String
Dim iR As Long, jC As Long, arrC, El, nrRows As Long, i As Long, strCountries As String, rngDel As Range
'put in an array the columns to be processed headers:
strCountries = "French, English, Bulgarian, Croatian, Czech, Danish, Dutch, Estonian, Finnish, German, Hebrew, Hungarian, Italian, Latvian, Lithuanian, Norwegian, Polish, Portuguese, Romanian, Russian, Serbian, Slovakian, Slovenian, Spanish, Turkish, Ukrainian"
arrC = Split(strCountries, ", ")
strSep = " " 'the separator between concatenated strings
Set sh = ActiveSheet 'you may use here your necessary sheet, if not the active one
lastC = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column on the first row (the one with the headers to be checked)
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each El In arrC 'iterate between the headers array elements
For jC = 1 To lastC 'iterate between existing columns of the first row (headers)
If UCase(sh.cells(1, jC).value) = UCase(El) Then 'if the header has been found
lastR = sh.cells(sh.rows.count, jC).End(xlUp).row 'determine the last row on the specific column
For iR = 3 To lastR 'iterate between all rows, starting from the third row
If sh.cells(iR, jC).Borders(xlEdgeTop).Weight = xlMedium And sh.cells(iR, jC) <> "" Then
Set rngB = getBordRng(sh.cells(iR, jC)) 'determine the range inside the border
If rngB Is Nothing Then GoTo OverProcessing 'in case of one row in the bordered area, the code jumps over the pocessing part
nrRows = rngB.rows.count 'the range number of rows
For i = 1 To nrRows - 1 'concatenate the range rows value to the first row
Application.Calculation = xlCalculationManual 'to be faster, not allowing calculations for each change
sh.cells(iR, jC).value = sh.cells(iR, jC).value & strSep & sh.cells(iR + i, jC).value 'the concatenation
sh.cells(iR + i, jC).value = "" 'clearing the cells below the above one
If rngDel Is Nothing Then
Set rngDel = sh.cells(iR + i, jC) 'the range to be deleted is built
Else
'check if there already is a cell on the analized row:
If Intersect(rngDel.EntireRow, sh.cells(iR + i, jC)) Is Nothing Then
Set rngDel = Union(rngDel, sh.cells(iR + i, jC)) 'place the cell in the row to be deleted
End If
End If
Application.Calculation = xlCalculationAutomatic
Next i
iR = iR + nrRows - 1 'increment the variable to start after the previous determined range
End If
OverProcessing:
Next iR
End If
Next jC
Next El
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Function getBordRng(c As Range) As Range
Dim iRow As Long, celBottom As Range, lastR As Long
If c.Borders(xlEdgeBottom).Weight = xlMedium Then
Set getBordRng = Nothing: Exit Function 'for the case of only one row
End If
lastR = c.Parent.cells(rows.count, c.Column).End(xlUp).row 'last row
For iRow = 1 To lastR
If c.Offset(iRow, 0).Borders(xlEdgeBottom).Weight = xlMedium Then
Set getBordRng = c.Parent.Range(c, c.Offset(iRow, 0)): Exit Function
End If
Next iRow
End Function