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:


[TABLE="class: stg_table tborder sortable"]
<tbody>[TR]
[TH][/TH]
[TH]col1 [/TH]
[TH]col2 [/TH]
[TH]col3 [/TH]
[TH]col4 [/TH]
[TH]col5[/TH]
[/TR]
[TR="class: alt2, bgcolor: #F5F5F5"]
[TD]row1[/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR="class: alt1, bgcolor: #FFFFFF"]
[TD]row2[/TD]
[TD]x[/TD]
[TD]a[/TD]
[TD]l[/TD]
[TD]g[/TD]
[TD][/TD]
[/TR]
[TR="class: alt2, bgcolor: #F5F5F5"]
[TD]row3[/TD]
[TD][/TD]
[TD]b[/TD]
[TD]m[/TD]
[TD]h[/TD]
[TD]Title A[/TD]
[/TR]
[TR="class: alt1, bgcolor: #FFFFFF"]
[TD]row4[/TD]
[TD][/TD]
[TD]c[/TD]
[TD]n[/TD]
[TD]i[/TD]
[TD][/TD]
[/TR]
[TR="class: alt2, bgcolor: #F5F5F5"]
[TD]row5[/TD]
[TD]x[/TD]
[TD]d[/TD]
[TD]o[/TD]
[TD]j[/TD]
[TD][/TD]
[/TR]
[TR="class: alt1, bgcolor: #FFFFFF"]
[TD]row6[/TD]
[TD][/TD]
[TD]e[/TD]
[TD]p[/TD]
[TD]k[/TD]
[TD]Title B[/TD]
[/TR]
[TR="class: alt2, bgcolor: #F5F5F5"]
[TD]row7[/TD]
[TD][/TD]
[TD]f[/TD]
[TD]q[/TD]
[TD]l[/TD]
[TD]Title C[/TD]
[/TR]
[TR="class: alt1, bgcolor: #FFFFFF"]
[TD]row8[/TD]
[TD][/TD]
[TD]g[/TD]
[TD]r[/TD]
[TD]m[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
The above table can be copied and dropped directly in to Excel


Needed format:

[TABLE="class: stg_table tborder sortable"]
<tbody>[TR]
[TH][/TH]
[TH]col1 [/TH]
[TH]col2 [/TH]
[TH]col3 [/TH]
[TH]col4 [/TH]
[TH]col5[/TH]
[/TR]
[TR="class: alt2, bgcolor: #F5F5F5"]
[TD]row1[/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR="class: alt1, bgcolor: #FFFFFF"]
[TD]row2[/TD]
[TD]x[/TD]
[TD]a b c[/TD]
[TD]l m n[/TD]
[TD]g h i[/TD]
[TD]Title A[/TD]
[/TR]
[TR="class: alt2, bgcolor: #F5F5F5"]
[TD]row3[/TD]
[TD]x[/TD]
[TD]d e f g[/TD]
[TD]o p q r[/TD]
[TD]j k l m[/TD]
[TD]Title B/Title C[/TD]
[/TR]
</tbody>[/TABLE]
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>
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Just noticed the last two tables didn't format correctly for alternative 2 (if alternative 1 isn't possible):

Current data format:


[TABLE="class: cms_table_stg_table cms_table_tborder cms_table_sortable"]
<tbody>[TR]
[TH="align: center"][/TH]
[TH="align: center"]col1[/TH]
[TH="align: center"]col2[/TH]
[TH="align: center"][/TH]
[TH="align: center"][/TH]
[TH="align: center"][/TH]
[/TR]
[TR="class: cms_table_alt2, bgcolor: #F5F5F5"]
[TD]row1[/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR="class: cms_table_alt1, bgcolor: #FFFFFF"]
[TD]row2[/TD]
[TD]x[/TD]
[TD]a[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR="class: cms_table_alt2, bgcolor: #F5F5F5"]
[TD]row3[/TD]
[TD][/TD]
[TD]b[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR="class: cms_table_alt1, bgcolor: #FFFFFF"]
[TD]row4[/TD]
[TD][/TD]
[TD]c[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR="class: cms_table_alt2, bgcolor: #F5F5F5"]
[TD]row5[/TD]
[TD]x[/TD]
[TD]d[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR="class: cms_table_alt1, bgcolor: #FFFFFF"]
[TD]row6[/TD]
[TD][/TD]
[TD]e[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Needed format:

[TABLE="class: cms_table_stg_table cms_table_tborder cms_table_sortable"]
<tbody>[TR]
[TH="align: center"][/TH]
[TH="align: center"]col1[/TH]
[TH="align: center"]col2[/TH]
[TH="align: center"][/TH]
[TH="align: center"][/TH]
[TH="align: center"][/TH]
[/TR]
[TR="class: cms_table_alt2, bgcolor: #F5F5F5"]
[TD]row1[/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR="class: cms_table_alt1, bgcolor: #FFFFFF"]
[TD]row2[/TD]
[TD]x[/TD]
[TD]a b c[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR="class: cms_table_alt2, bgcolor: #F5F5F5"]
[TD]row3[/TD]
[TD]x[/TD]
[TD]d e f g[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0
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?
 
Upvote 0
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?
 
Upvote 0
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?
 
Upvote 0

Forum statistics

Threads
1,223,098
Messages
6,170,106
Members
452,302
Latest member
TaMere

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
Back
Top