Answered by:
Loop to merge range of adjacent cells, skip the blank row, and merge next range
Question

I thought this would be easy, but I’m struggling a bit. I’ve got a bunch of rows, thousands, actually. I’m trying to select rows that are adjacent, until a blank row is found, and merge the selected cells into one single cell. I’m working with the code below.
Sub MergeUntilBlank() 'Dim Wks As Worksheet Dim Col As Range Dim Ar As Range On Error Resume Next Application.DisplayAlerts = False 'For Each Wks In Worksheets For Each Col In Wks.UsedRange.Columns For Each Ar In Col.SpecialCells(xlCellTypeBlanks).Areas Ar.Select Range(Selection, Selection.End(xlDown)).Select ActiveCell.Offset(1, 0).Select Range(Selection, Selection.End(xlDown)).Select Selection.Merge Next Next 'Next Columns.VerticalAlignment = xlVAlignCenter Application.DisplayAlerts = True End Sub
This seems to work, sort of. At the beginning it seems to run fine, but then after several dozen rows, things get screwy, and I can’t tell why. The count is off, or the data changes somehow. Not sure. Any thoughts anyone?
Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.
Answers

Or, is there a better way to group these items, so the terms and definitions are together after I do an alphasort?
IMHO yes. But before we start with that, run this macro in your sample file:
Sub Issue() Dim R As Range For Each R In Columns("A").SpecialCells(xlCellTypeConstants).Areas Debug.Print R.Address Next End Sub
That is the reason why your first macro fails, many of the cells contains a blank. And SpecialCells, resp. Range.End stops only on empty cells.
Okay, the question is what is the next step after you have all this informations in a appropriate form?
I would store the terms and definition in a way that makes it easy and quick to search and find a term and get the definition. The obvious solution is to store the terms in column A and the definitions in column B, without any empty cell.
The data in your sample file has 2 structures:
a) terms and definition in 1 line separated by a ""
b) terms and definition in 2 lines surrounded by an "empty" lineSo we have to prepare and analyze the data before we can build the output.
Afterwards you can sort by column A, or write a macro that search in column A and get the definition from column B same row (and maybe output the result in a MsgBox or Userform).
Andreas.
Sub Main() Dim Data Dim i As Long, j As Long, k As Long 'Step 1: 'Read in all data Data = Range("A1", Range("A" & Rows.Count).End(xlUp)) 'Prepare for Step 2 For i = 1 To UBound(Data) 'Trim spaces Data(i, 1) = Trim$(Data(i, 1)) 'Set "" strings to Empty If Len(Data(i, 1)) = 0 Then Data(i, 1) = Empty Next 'Step 2: 'Add a column ReDim Preserve Data(1 To UBound(Data), 1 To 2) For i = 1 To UBound(Data) 'If we have text If Not IsEmpty(Data(i, 1)) Then 'Next output row k = k + 1 'Item splitted into 2 rows? If AtDoubleRow(Data, i) Then 'Yes, combine with the next row Data(k, 1) = Trim$(Data(i, 1)) Data(k, 2) = Trim$(Data(i + 1, 1)) 'Skip the next 2 rows i = i + 2 Else 'No, split this item at "" j = InStr(Data(i, 1), "") Data(k, 2) = Trim$(Mid$(Data(i, 1), j + 1)) Data(k, 1) = Trim$(Left$(Data(i, 1), j  1)) End If End If Next 'Step 3: 'Create the output Sheets.Add After:=Sheets(ActiveSheet.Index) Range("A1").Resize(k, UBound(Data, 2)) = Data Columns("A").AutoFit End Sub Private Function AtDoubleRow(ByRef Data, ByVal LinePtr As Long) As Boolean 'Check if we hit this structure in Data: 'Empty 'Text < LinePtr 'Text 'Empty On Error GoTo ExitPoint 'The row before must be empty (if there is one) If LinePtr > 1 Then If Not IsEmpty(Data(LinePtr  1, 1)) Then Exit Function End If 'This row must be filled If IsEmpty(Data(LinePtr, 1)) Then Exit Function 'The next row must be filled If IsEmpty(Data(LinePtr + 1, 1)) Then Exit Function 'The row below must be empty (if there is one) If LinePtr + 2 <= UBound(Data) Then If Not IsEmpty(Data(LinePtr + 2, 1)) Then Exit Function End If 'All tests passed: AtDoubleRow = True ExitPoint: End Function
 Marked as answer by ryguy72 Monday, April 27, 2015 1:12 PM
All replies

Please never use SELECT, SELECTION, ACTIVECELL, it is slow and error prone. Always refer to the objects directly.
If you need further help please upload your file (maybe with anonymous data) on an online file hoster like www.dropbox.com and post the download link here.
I'm struggling to understand which of the cells you want to merge.
Andreas.

Ok, here’s a sample.
https://www.dropbox.com/s/gq36ib3fr6w10oc/Accounting_Terms.xlsx?dl=0
I have a list of terms from 3 online dictionaries. I want to merge the cells starting in A40, so A40 & A41 are merged into one cell, B43 & B44 are merged, and so on. This way, I can sort everything. Now, if I sort, all the terms and definitions will be completely mixed up.
Or, is there a better way to group these items, so the terms and definitions are together after I do an alphasort?
Thanks!
Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

Or, is there a better way to group these items, so the terms and definitions are together after I do an alphasort?
IMHO yes. But before we start with that, run this macro in your sample file:
Sub Issue() Dim R As Range For Each R In Columns("A").SpecialCells(xlCellTypeConstants).Areas Debug.Print R.Address Next End Sub
That is the reason why your first macro fails, many of the cells contains a blank. And SpecialCells, resp. Range.End stops only on empty cells.
Okay, the question is what is the next step after you have all this informations in a appropriate form?
I would store the terms and definition in a way that makes it easy and quick to search and find a term and get the definition. The obvious solution is to store the terms in column A and the definitions in column B, without any empty cell.
The data in your sample file has 2 structures:
a) terms and definition in 1 line separated by a ""
b) terms and definition in 2 lines surrounded by an "empty" lineSo we have to prepare and analyze the data before we can build the output.
Afterwards you can sort by column A, or write a macro that search in column A and get the definition from column B same row (and maybe output the result in a MsgBox or Userform).
Andreas.
Sub Main() Dim Data Dim i As Long, j As Long, k As Long 'Step 1: 'Read in all data Data = Range("A1", Range("A" & Rows.Count).End(xlUp)) 'Prepare for Step 2 For i = 1 To UBound(Data) 'Trim spaces Data(i, 1) = Trim$(Data(i, 1)) 'Set "" strings to Empty If Len(Data(i, 1)) = 0 Then Data(i, 1) = Empty Next 'Step 2: 'Add a column ReDim Preserve Data(1 To UBound(Data), 1 To 2) For i = 1 To UBound(Data) 'If we have text If Not IsEmpty(Data(i, 1)) Then 'Next output row k = k + 1 'Item splitted into 2 rows? If AtDoubleRow(Data, i) Then 'Yes, combine with the next row Data(k, 1) = Trim$(Data(i, 1)) Data(k, 2) = Trim$(Data(i + 1, 1)) 'Skip the next 2 rows i = i + 2 Else 'No, split this item at "" j = InStr(Data(i, 1), "") Data(k, 2) = Trim$(Mid$(Data(i, 1), j + 1)) Data(k, 1) = Trim$(Left$(Data(i, 1), j  1)) End If End If Next 'Step 3: 'Create the output Sheets.Add After:=Sheets(ActiveSheet.Index) Range("A1").Resize(k, UBound(Data, 2)) = Data Columns("A").AutoFit End Sub Private Function AtDoubleRow(ByRef Data, ByVal LinePtr As Long) As Boolean 'Check if we hit this structure in Data: 'Empty 'Text < LinePtr 'Text 'Empty On Error GoTo ExitPoint 'The row before must be empty (if there is one) If LinePtr > 1 Then If Not IsEmpty(Data(LinePtr  1, 1)) Then Exit Function End If 'This row must be filled If IsEmpty(Data(LinePtr, 1)) Then Exit Function 'The next row must be filled If IsEmpty(Data(LinePtr + 1, 1)) Then Exit Function 'The row below must be empty (if there is one) If LinePtr + 2 <= UBound(Data) Then If Not IsEmpty(Data(LinePtr + 2, 1)) Then Exit Function End If 'All tests passed: AtDoubleRow = True ExitPoint: End Function
 Marked as answer by ryguy72 Monday, April 27, 2015 1:12 PM
