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>

 

[jeffsdan]

Just noticed the last two tables didn't format correctly for alternative 2 (if alternative 1 isn't possible):

Current data format:

	col1	col2
row1	A	B
row2	x	a
row3		b
row4		c
row5	x	d
row6		e

<tbody>
</tbody>

Needed format:

	col1	col2
row1	A	B
row2	x	a b c
row3	x	d e f g

<tbody>
</tbody>

 

[timfritsch]

You may need to change the startRow and startCol for your specific table. This code loops through your data, and consolidates the data in a new worksheet.

Option Explicit

Sub test()
  Dim i As Long, j As Long, startRow As Long, endRow As Long, startCol As Long, endCol As Long, pasteRow As Long
  Dim sht1 As String, sht2 As String
  
  sht1 = ActiveSheet.Name
  
  startRow = 3
  startCol = 2          'Column with "x"
  
  endRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
  endCol = Range("A1").SpecialCells(xlCellTypeLastCell).Column
  
  Sheets.Add after:=Sheets(1)
  
  sht2 = ActiveSheet.Name
  
  pasteRow = 1
  
  With Sheets(sht1)
    For i = startRow To endRow
      If .Cells(i, startCol) = "x" Then
        For j = 1 To 4            'loop through columns 2 to 5
          Sheets(sht2).Cells(pasteRow, j) = .Cells(i, startCol + j)
        Next j
        
        If Len(.Cells(i + 1, startCol)) = 0 Then        'contine until next instance of "x"
          i = i + 1
          
          Do While Len(.Cells(i, startCol)) = 0
            For j = 1 To 3
              Sheets(sht2).Cells(pasteRow, j) = Sheets(sht2).Cells(pasteRow, j) & " " & .Cells(i, startCol + j)
            Next j
            
            j = 4
            If Len(.Cells(i, startCol + j)) > 0 Then
              If Len(Sheets(sht2).Cells(pasteRow, j)) = 0 Then
                Sheets(sht2).Cells(pasteRow, j) = .Cells(i, startCol + j)
              Else
                Sheets(sht2).Cells(pasteRow, j) = Sheets(sht2).Cells(pasteRow, j) & "/" & .Cells(i, startCol + j)
              End If
            End If
            
            i = i + 1
            
            If i > endRow Then Exit Sub
          Loop
          
          pasteRow = pasteRow + 1
        End If
      End If
      
      i = i - 1
    Next i
  End With
End Sub

Hope this helps.


Tim

 

[jeffsdan]

I gave it a shot and it just froze the sheet. I tried just using just the sample data from above, but it froze too. Not sure why. Thoughts?

You may need to change the startRow and startCol for your specific table. This code loops through your data, and consolidates the data in a new worksheet.

Option Explicit

Sub test()
  Dim i As Long, j As Long, startRow As Long, endRow As Long, startCol As Long, endCol As Long, pasteRow As Long
  Dim sht1 As String, sht2 As String
  
  sht1 = ActiveSheet.Name
  
  startRow = 3
  startCol = 2          'Column with "x"
  
  endRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
  endCol = Range("A1").SpecialCells(xlCellTypeLastCell).Column
  
  Sheets.Add after:=Sheets(1)
  
  sht2 = ActiveSheet.Name
  
  pasteRow = 1
  
  With Sheets(sht1)
    For i = startRow To endRow
      If .Cells(i, startCol) = "x" Then
        For j = 1 To 4            'loop through columns 2 to 5
          Sheets(sht2).Cells(pasteRow, j) = .Cells(i, startCol + j)
        Next j
        
        If Len(.Cells(i + 1, startCol)) = 0 Then        'contine until next instance of "x"
          i = i + 1
          
          Do While Len(.Cells(i, startCol)) = 0
            For j = 1 To 3
              Sheets(sht2).Cells(pasteRow, j) = Sheets(sht2).Cells(pasteRow, j) & " " & .Cells(i, startCol + j)
            Next j
            
            j = 4
            If Len(.Cells(i, startCol + j)) > 0 Then
              If Len(Sheets(sht2).Cells(pasteRow, j)) = 0 Then
                Sheets(sht2).Cells(pasteRow, j) = .Cells(i, startCol + j)
              Else
                Sheets(sht2).Cells(pasteRow, j) = Sheets(sht2).Cells(pasteRow, j) & "/" & .Cells(i, startCol + j)
              End If
            End If
            
            i = i + 1
            
            If i > endRow Then Exit Sub
          Loop
          
          pasteRow = pasteRow + 1
        End If
      End If
      
      i = i - 1
    Next i
  End With
End Sub

Hope this helps.


Tim

 

[timfritsch]

Without seeing your file, its hard to troubleshoot. I'll send you a PM with my email address and if you'd like to send me your file I'll take a look.


Tim

 

[timfritsch]

Code revised. Not sure the output is what you want. If you mock up the first 3 paragraphs as you'd like the output to be, I can tweak the code to give you what you need.

Also, for this version of the code to work, you need an "x" in the first detail row (cell A2).

Sub test()
  Dim i As Long, j As Long, startRow As Long, endRow As Long, startCol As Long, endCol As Long, pasteRow As Long
  Dim sht1 As String, sht2 As String
  
  sht1 = ActiveSheet.Name
  
  startRow = 2
  startCol = 1          'Column with "x"
  
  endRow = Cells(Rows.Count, "B").End(xlUp).Row
  endCol = Cells(1, Columns.Count).End(xlToLeft).Column
  
  Sheets.Add after:=Sheets(1)
  
  sht2 = ActiveSheet.Name
  
  pasteRow = 1
  
  With Sheets(sht1)
    For i = startRow To endRow
      If .Cells(i, startCol) = "x" Then
        If Len(.Cells(i + 1, startCol)) = 0 Then        'continue until next instance of "x"
          Sheets(sht2).Cells(pasteRow, 2) = .Cells(i, 2)
          
          i = i + 1
          
          Do While Len(.Cells(i, startCol)) = 0
            Sheets(sht2).Cells(pasteRow, 2) = Sheets(sht2).Cells(pasteRow, 2) & " " & .Cells(i, 2)
            
            i = i + 1
            
            If i > endRow Then Exit Sub
          Loop
          
          pasteRow = pasteRow + 1
        End If
        i = i - 1
      End If
    Next i
  End With
End Sub

Tim

 

[jeffsdan]

Tried running it on a couple lines of the spreadsheet and it worked, but when I tried to run it on the whole spreadsheet, it just froze. I let it run for 3 days in hopes it was just taking a long time, with no luck. Thoughts?

 

[jeffsdan]

I think something about the cell contents is freezing the macro, because it works on big chunks of the data, but is freezing between rows 89 and 97 for some reason. Thoughts?

 

[Rick Rothstein]

I think something about the cell contents is freezing the macro, because it works on big chunks of the data, but is freezing between rows 89 and 97 for some reason. Thoughts?

Let's try to get a sense of things... how many rows of data do you have and how many columns are they spread across?

 

[jeffsdan]

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?