I've attached a mini sample file that contains the common variationsThe attachments didn't appear in your question. When you upload a file, you need to:
Sub Concatenater()
Dim Col As Variant, v As Variant
Dim i As Long, iCol As Long, iKeep As Long, j As Long, n As Long
Dim rg As Range
Dim s As String, sConcat As String, sDelimiter As String
Application.ScreenUpdating = False
sDelimiter = ";" 'Delimiter for concatenated string
With ActiveSheet
Set rg = .Range("A2")
Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp)) 'All the data in column A
End With
n = rg.Rows.Count
For Each Col In Array("C", "E") 'Columns to be concatenated
sConcat = sDelimiter
iCol = Range(Col & "1").Column
v = ""
For i = 1 To n
s = rg.Cells(i, iCol).Value
If s <> "" Then s = s & sDelimiter
If v = rg.Cells(i, 1).Value Then
If s <> "" Then
If InStr(1, sConcat, sDelimiter & s) = 0 Then sConcat = sConcat & s
End If
Else
If v <> "" Then rg.Cells(iKeep, iCol) = Mid(sConcat, Len(sDelimiter) + 1, Len(sConcat) - 2 * Len(sDelimiter))
iKeep = i
sConcat = sDelimiter
If s <> "" Then sConcat = sConcat & s
v = rg.Cells(i, 1).Value
End If
Next
If v <> "" Then rg.Cells(iKeep, iCol) = Mid(sConcat, Len(sDelimiter) + 1, Len(sConcat) - 2 * Len(sDelimiter))
Next
v = ""
For i = n To 1 Step -1
If rg.Cells(i, 1).Value = v Then
rg.Cells(i + 1).EntireRow.Delete
Else
v = rg.Cells(i, 1).Value
End If
Next
End Sub
Sub Concatenater()
Dim Col As Variant, v As Variant
Dim i As Long, iCol As Long, iKeep As Long, j As Long, n As Long
Dim rg As Range
Dim s As String, sConcat As String, sDelimiter As String
Application.ScreenUpdating = False
sDelimiter = ";" 'Delimiter for concatenated string
With ActiveSheet
Set rg = .Range("A2")
Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp)) 'All the data in column A
End With
n = rg.Rows.Count
For Each Col In Array("C", "E") 'Columns to be concatenated
sConcat = sDelimiter
iCol = Range(Col & "1").Column
v = ""
For i = 1 To n
s = rg.Cells(i, iCol).Value
If s <> "" Then s = s & sDelimiter
If v = rg.Cells(i, 1).Value Then
If s <> "" Then
If InStr(1, sConcat, sDelimiter & s) = 0 Then sConcat = sConcat & s
End If
Else
If (v <> "") And (Len(sConcat) > 2 * Len(sDelimiter)) Then _
rg.Cells(iKeep, iCol) = Mid(sConcat, Len(sDelimiter) + 1, Len(sConcat) - 2 * Len(sDelimiter))
iKeep = i
sConcat = sDelimiter
If s <> "" Then sConcat = sConcat & s
v = rg.Cells(i, 1).Value
End If
Next
If (v <> "") And (Len(sConcat) > 2 * Len(sDelimiter)) Then _
rg.Cells(iKeep, iCol) = Mid(sConcat, Len(sDelimiter) + 1, Len(sConcat) - 2 * Len(sDelimiter))
Next
v = ""
For i = n To 1 Step -1
If rg.Cells(i, 1).Value = v Then
rg.Cells(i + 1).EntireRow.Delete
Else
v = rg.Cells(i, 1).Value
End If
Next
End Sub
Sub Deconcatenater()
Dim Col As Variant, ConcatColumns As Variant, v As Variant
Dim i As Long, iCol As Long, k As Long, nRows As Long, nCols As Long
Dim rg As Range
Dim s As String, sConcat As String, sDelimiter As String
Application.ScreenUpdating = False
sDelimiter = ";" 'Delimiter for concatenated string
ConcatColumns = Array("C", "E") 'Concatenated columns
With ActiveSheet
Set rg = .Range("A2") 'First cell with Content ID. Header labels assumed to be in previous row.
nCols = .Cells(rg.Row - 1, .Columns.Count).End(xlToLeft).Column - rg.Column + 1
Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp)) 'All the data in column A
nRows = rg.Rows.Count
Set rg = rg.Resize(nRows, nCols) 'All the data in table
End With
For i = nRows To 1 Step -1
k = 0 'Number of rows to be added
For Each Col In ConcatColumns
iCol = Range(Col & "1").Column
s = rg.Cells(i, iCol).Value
k = Application.Max(k, Len(s) - Len(Replace(s, sDelimiter, "")))
Next
If k > 0 Then
rg.Rows(i + 1).Resize(k).EntireRow.Insert
rg.Rows(i + 1).Resize(k).Value = rg.Rows(i).Value
For Each Col In ConcatColumns
iCol = Range(Col & "1").Column
s = rg.Cells(i, iCol).Value
If s <> "" Then rg.Cells(i, iCol).Resize(k + 1, 1).Value = Application.Transpose(Split(s, sDelimiter))
Next
End If
Next
End Sub
Sample-FileQ28324185.xlsm
Sub Concatenater()
Dim Col As Variant, v As Variant
Dim i As Long, iCol As Long, iKeep As Long, j As Long, n As Long
Dim rg As Range
Dim s As String, sConcat As String, sDelimiter As String, sFull
Application.ScreenUpdating = False
sDelimiter = ";" 'Delimiter for concatenated string
With ActiveSheet
Set rg = .Range("A2")
Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp)) 'All the data in column A
End With
n = rg.Rows.Count
For Each Col In Array("C", "E") 'Columns to be concatenated
sConcat = sDelimiter
iCol = Range(Col & "1").Column
v = ""
For i = 1 To n
If Not rg.Cells(i, iCol).Comment Is Nothing Then rg.Cells(i, iCol).Comment.Delete
s = rg.Cells(i, iCol).Value
If s <> "" Then s = s & sDelimiter
If v = rg.Cells(i, 1).Value Then
sFull = sFull & rg.Cells(i, iCol).Value & sDelimiter
If s <> "" Then
If InStr(1, sConcat, sDelimiter & s) = 0 Then sConcat = sConcat & s
End If
Else
If (v <> "") And (Len(sConcat) > 2 * Len(sDelimiter)) Then _
rg.Cells(iKeep, iCol) = Mid(sConcat, Len(sDelimiter) + 1, Len(sConcat) - 2 * Len(sDelimiter))
If Len(sFull) > 2 * Len(sDelimiter) Then
rg.Cells(iKeep, iCol).AddComment Mid(sFull, Len(sDelimiter) + 1, Len(sFull) - 2 * Len(sDelimiter))
End If
iKeep = i
sConcat = sDelimiter
sFull = sDelimiter & rg.Cells(i, iCol).Value & sDelimiter
If s <> "" Then sConcat = sConcat & s
v = rg.Cells(i, 1).Value
End If
Next
If Len(sFull) > 2 * Len(sDelimiter) Then
rg.Cells(iKeep, iCol).AddComment Mid(sFull, Len(sDelimiter) + 1, Len(sFull) - 2 * Len(sDelimiter))
End If
If (v <> "") And (Len(sConcat) > 2 * Len(sDelimiter)) Then _
rg.Cells(iKeep, iCol) = Mid(sConcat, Len(sDelimiter) + 1, Len(sConcat) - 2 * Len(sDelimiter))
Next
v = ""
For i = n To 1 Step -1
If rg.Cells(i, 1).Value = v Then
rg.Cells(i + 1).EntireRow.Delete
Else
v = rg.Cells(i, 1).Value
End If
Next
End Sub
Sub Deconcatenater()
Dim Col As Variant, ConcatColumns As Variant, v As Variant
Dim i As Long, iCol As Long, k As Long, nRows As Long, nCols As Long
Dim rg As Range
Dim s As String, sConcat As String, sDelimiter As String
Application.ScreenUpdating = False
sDelimiter = ";" 'Delimiter for concatenated string
ConcatColumns = Array("C", "E") 'Concatenated columns
With ActiveSheet
Set rg = .Range("A2") 'First cell with Content ID. Header labels assumed to be in previous row.
nCols = .Cells(rg.Row - 1, .Columns.Count).End(xlToLeft).Column - rg.Column + 1
Set rg = Range(rg, .Cells(.Rows.Count, rg.Column).End(xlUp)) 'All the data in column A
nRows = rg.Rows.Count
Set rg = rg.Resize(nRows, nCols) 'All the data in table
End With
For i = nRows To 1 Step -1
k = 0 'Number of rows to be added
For Each Col In ConcatColumns
iCol = Range(Col & "1").Column
If Not rg.Cells(i, iCol).Comment Is Nothing Then
s = rg.Cells(i, iCol).Comment.Text
k = Application.Max(k, Len(s) - Len(Replace(s, sDelimiter, "")))
End If
Next
If k > 0 Then
rg.Rows(i + 1).Resize(k).EntireRow.Insert
rg.Rows(i + 1).Resize(k).Value = rg.Rows(i).Value
For Each Col In ConcatColumns
iCol = Range(Col & "1").Column
If Not rg.Cells(i, iCol).Comment Is Nothing Then
s = rg.Cells(i, iCol).Comment.Text
If s <> "" Then rg.Cells(i, iCol).Resize(k + 1, 1).Value = Application.Transpose(Split(s, sDelimiter))
End If
Next
End If
For Each Col In ConcatColumns
iCol = Range(Col & "1").Column
If Not rg.Cells(i, iCol).Comment Is Nothing Then rg.Cells(i, iCol).Comment.Delete
Next
Next
End Sub
BradIf you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.