combine mutiple values into single cell based on criteria

[syed_iqbal]

HI,


Pls find the attachment. In the first sheet , i mentioned sample data. After running the macro i need the result as in second sheet (sheet name: "Resulted Data").

Thank you in advance.

Regards
syed

[JBeaucaire]

This macro will do as you've outlined:


Option Explicit
Sub ReformatData()
Dim inARR As Variant, outARR As Variant, i As Long, o As Long, LR As Long

inARR = Sheets("Source Data").Range("A1").CurrentRegion.Value
ReDim outARR(1 To UBound(inARR), 1 To 2)
For i = 2 To UBound(inARR)
If IsDate(inARR(i, 1)) Then
For o = 1 To UBound(outARR)
If outARR(o, 1) = "" Then
outARR(o, 1) = inARR(i, 3)
outARR(o, 2) = "(SD: " & Format(inARR(i, 1), "DD-MM-YYYY") & ", ED: " & Format(inARR(i, 2), "DD-MM-YYYY") & ")"
Exit For
ElseIf CStr(inARR(i, 3)) = CStr(outARR(o, 1)) Then
outARR(o, 2) = outARR(o, 2) & " | (SD: " & Format(inARR(i, 1), "DD-MM-YYYY") & ", ED: " & Format(inARR(i, 2), "DD-MM-YYYY") & ")"
Exit For
End If
Next o
End If
Next i

With Sheets("Resulted Data")
.UsedRange.Offset(1).Clear
.Range("A2").Resize(UBound(outARR)).NumberFormat = "@"
.Range("A2:B2").Resize(UBound(outARR)).Value = outARR
LR = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A2:B" & LR)
.Borders.Weight = xlThin
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
End With

End Sub