Macro to save a life, Combine Cell Contents based on other Cell Value

[jeffsdan]

I am having an impossible time finding a solution for this. I need to combine cell contents in an unusual way (see below), based on if there is an "x" in column A. See below for the exact representation of what I need to do in a worksheet with 200,000 total cells of content. Is there any hope? Anyone who can help will be my personal hero for life, and you may save a life (mine!)!


Current data format:

	col1	col2	col3	col4	col5
row1	A	B	C	D	E
row2	x	a	l	g
row3		b	m	h	Title A
row4		c	n	i
row5	x	d	o	j
row6		e	p	k	Title B
row7		f	q	l	Title C
row8		g	r	m

<tbody>
</tbody>

The above table can be copied and dropped directly in to Excel


Needed format:

	col1	col2	col3	col4	col5
row1	A	B	C	D	E
row2	x	a b c	l m n	g h i	Title A
row3	x	d e f g	o p q r	j k l m	Title B/Title C

<tbody>
</tbody>

The above table can be copied and dropped directly in to Excel


If no solution to the above can be found, perhaps I could do this one column at a time by copying the individual columns into separate sheets, run a Macro, then copy the reformatted info back (EG, just do column A and one other column at a time like below). I am not sure of any other options or approaches to accomplishing this, but an open to thoughts.

Current data format:

• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;">A B </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;">x a </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;"> b </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;"> c </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;">x d </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;"> e </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;"> f </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;"> g </code>

<code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;">
Needed format:

• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;">A B </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;">x a b c </code>
• <code class="language-vb" style="font-family: Consolas, Monaco, 'Courier New', Courier, monospace;">x d e f g </code>

</code>

 

[Rick Rothstein]

Awe, I think I know what's wrong, the Macro freezes on rows where two consecutive rows have an "X" in the first column. Any way to prevent that?

I have some alternate code in mind, but it may be sensitive to the size of your data... can you answer the questions I asked in my last message please?

 

[jeffsdan]

31,000 rows, one column (column A) with "x"s, and five columns (B,C,D,E,F) with data. The data averages ~130 characters each cell.

 

[Rick Rothstein]

31,000 rows, one column (column A) with "x"s, and five columns (B,C,D,E,F) with data. The data averages ~130 characters each cell.

Sorry, one more question... what is the lowest version of Excel that the macro for this functionality will run on? I am interested in whether they will all be XL2010 or later or not.

 

[jeffsdan]

Excel 2010 only

 

[Rick Rothstein]

Excel 2010 only

Perfect, that makes it easier (no limit on one of the functions I need to use). Give this macro a try...

Sub CombineBlanksWithCellAboveByConcatenatingOtherColumns()
  Dim X As Long, LastRow As Long, Text As String, Blanks As Range, Ar As Range
  LastRow = Columns("B:E").Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
  With Range("A1:A" & LastRow).SpecialCells(xlBlanks)
    For Each Ar In .Areas
      For X = 1 To 4
        With Ar(1).Offset(-1).Offset(, X)
          Text = Application.Trim(Join(Application.Transpose(.Resize(Ar.Rows.Count + 1).Value), IIf(X = 4, "/", " ")))
          If X = 4 Then
            Text = Replace(Replace(Application.Trim(Replace(Replace(Text, " ", Chr(1)), "/", " ")), " ", "/"), Chr(1), " ")
          End If
          .Value = Text
        End With
      Next
    Next
    .EntireRow.Delete
  End With
End Sub

 

[jeffsdan]

Tried running it, it said "run time error 1004, no cells were found"

 

[Rick Rothstein]

Tried running it, it said "run time error 1004, no cells were found"

Can you send me a copy of the file so that I can see what the difference is between the test data I set up based on your description of the data (on which the code worked perfectly) and your actual physical code? My email address is...

rick DOT news AT verizon DOT net

Please include the name of this thread in your response (so I can link your file back to this thread).

 

[jeffsdan]

on its way