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

jeffsdan

New Member
Joined
Feb 13, 2014
Messages
13
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
row1ABCDE
row2xalg
row3bmhTitle A
row4cni
row5xdoj
row6epkTitle B
row7fqlTitle C
row8grm

<tbody>
</tbody>
The above table can be copied and dropped directly in to Excel


Needed format:

col1 col2 col3 col4 col5
row1ABCDE
row2xa b cl m ng h iTitle A
row3xd e f go p q rj k l mTitle 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>
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

jeffsdan

New Member
Joined
Feb 13, 2014
Messages
13
Just noticed the last two tables didn't format correctly for alternative 2 (if alternative 1 isn't possible):

Current data format:


col1col2
row1AB
row2xa
row3b
row4c
row5xd
row6e

<tbody>
</tbody>


Needed format:

col1col2
row1AB
row2xa b c
row3xd e f g

<tbody>
</tbody>
 

timfritsch

Active Member
Joined
Jun 10, 2004
Messages
343
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.

Code:
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

New Member
Joined
Feb 13, 2014
Messages
13
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.

Code:
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

Active Member
Joined
Jun 10, 2004
Messages
343

ADVERTISEMENT

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

Active Member
Joined
Jun 10, 2004
Messages
343
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).

Code:
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

New Member
Joined
Feb 13, 2014
Messages
13

ADVERTISEMENT

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

New Member
Joined
Feb 13, 2014
Messages
13
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

MrExcel MVP
Joined
Apr 18, 2011
Messages
36,686
Office Version
  1. 2010
Platform
  1. Windows
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

New Member
Joined
Feb 13, 2014
Messages
13
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?
 

Watch MrExcel Video

Forum statistics

Threads
1,122,589
Messages
5,597,053
Members
414,118
Latest member
moversnpackers

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top