Concatenate cells in a column until specific cell value

[heinz81]

Hi everyone,

I'm a newbie with VB and excel whose stuck at a task since quite a while.

I promise I went through the threads already and found a similar one here for blank values. Tried modifying the code but it didn't work for me for multiple scenarios, the only one I could spot was for consecutive values. My version failed to recognize consecutive entries, which I need to count as blank/empty values (instead of deleting them altogether). I am hoping the excel gurus here can help me with this.

To give an example of what I am trying to accomplish, I have data for multiple entries and it is separated by the year. I want to concatenate all values that fall until the next 'year value' is reached. I will be running the macros a few times by changing the 'fixed value (year date)', but I can do that manually.

Current Data
2005
The
first
entry
values
are
here
2005
Second
values
here
2005
2005
2005
Fifth
entry
has values

Desired output to be
<row 1=""> The first entry values are here
<row 2=""> Second values here
<row 3="">
<row 4="">
<row 5=""> Fifth entry has values

I would really appreciate any help that you could offer me. Thank you so much in advance!</row></row></row></row></row>

 

[heinz81]

Just to clarify, in the desired output, the third and fourth rows are blank. So the values for corresponding row numbers are:

1. The first entry values are here
<row 2="" style="color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">2. Second values here
<row 3="">3. :blank:
<row 4="">4. :blank:
<row 5="">5. Fifth entry has values </row></row></row></row>

 

[bhos123]

Sub macro1()
Dim lastRow As Long
Dim lastcolumn As Long
Application.DisplayAlerts = False

lastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Cells(lastRow, 2).Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[-1]*1),1,0)"
For i = lastRow To 2 Step -1
Cells(i - 1, 2).Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[-1]*1),1,0)"
If Cells(i, 2).Value = 0 And Cells(i - 1, 2).Value = 0 Then
Cells(i - 1, 1).Value = Cells(i - 1, 1).Value & " " & Cells(i, 1).Value
Rows(i).EntireRow.Delete
ElseIf Cells(i, 2).Value = 1 And Cells(i - 1, 2).Value = 0 Then
Rows(i).EntireRow.Delete
ElseIf Cells(i, 2).Value = 1 And Cells(i - 1, 2).Value = 1 Then
Rows(i).EntireRow.ClearContents

End If

Next
Application.DisplayAlerts = True
Rows(1).EntireRow.Delete
Columns(2).EntireColumn.ClearContents
End Sub

 

[Peter_SSs]

Welcome to the MrExcel board!

You could also try this in a copy of your workbook.
I have assumed ..
- Data in column A, starting in row 2
- Results in column B.

Sub Concat()
  Dim a As Variant, b As Variant
  Dim s As String
  Dim i As Long, k As Long
  
  a = Range("A2", Range("A" & Rows.Count).End(xlUp).Offset(1)).Value
  a(UBound(a), 1) = 1
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 2 To UBound(a)
    If IsNumeric(a(i, 1)) Then
      k = k + 1
      b(k, 1) = Mid(s, 2)
      s = vbNullString
    Else
      s = s & " " & a(i, 1)
    End If
  Next i
  With Range("B2").Resize(k)
    .Value = b
    .Columns.AutoFit
  End With
End Sub

Excel Workbook
	A	B
1	Current Data	Result of Code
2	2005	The first entry values are here
3	The	Second values here
4	first
5	entry
6	values	Fifth entry has values
7	are
8	here
9	2005
10	Second
11	values
12	here
13	2005
14	2005
15	2005
16	Fifth
17	entry
18	has values
19
Sheet1

 

[heinz81]

This works like a charm. Thank you so much Peter for your prompt response

 

[heinz81]

@bhos123 Thank you so much for helping me out. Not sure why, but this one really heated up my machine. But this certainly works.
I really owe you and Peter one! You guys are awesome

Sub macro1()
Dim lastRow As Long
Dim lastcolumn As Long
Application.DisplayAlerts = False

lastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Cells(lastRow, 2).Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[-1]*1),1,0)"
For i = lastRow To 2 Step -1
Cells(i - 1, 2).Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[-1]*1),1,0)"
If Cells(i, 2).Value = 0 And Cells(i - 1, 2).Value = 0 Then
Cells(i - 1, 1).Value = Cells(i - 1, 1).Value & " " & Cells(i, 1).Value
Rows(i).EntireRow.Delete
ElseIf Cells(i, 2).Value = 1 And Cells(i - 1, 2).Value = 0 Then
Rows(i).EntireRow.Delete
ElseIf Cells(i, 2).Value = 1 And Cells(i - 1, 2).Value = 1 Then
Rows(i).EntireRow.ClearContents

End If

Next
Application.DisplayAlerts = True
Rows(1).EntireRow.Delete
Columns(2).EntireColumn.ClearContents
End Sub

 

[bhos123]

Welcome

 

[Peter_SSs]

This works like a charm. Thank you so much Peter for your prompt response

Glad to contribute.