none
Loop to merge range of adjacent cells, skip the blank row, and merge next range RRS feed

  • 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.

    Thursday, April 23, 2015 9:57 PM

Answers

  • Or, is there a better way to group these items, so the terms and definitions are together after I do an alpha-sort?

    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" line

    So 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
    Saturday, April 25, 2015 10:53 AM

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.

    Friday, April 24, 2015 8:58 AM
  • 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 alpha-sort?

     

    Thanks!

     


    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Friday, April 24, 2015 12:19 PM
  • Or, is there a better way to group these items, so the terms and definitions are together after I do an alpha-sort?

    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" line

    So 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
    Saturday, April 25, 2015 10:53 AM
  • Thanks for the help with this!!

    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Monday, April 27, 2015 1:12 PM