VBA: concatenate multiple cell data

[ucan]

Please help me to concatenate multiple cell data in output 1 and output2 exactly in the same way as it appears in the attached excel sheet.
I have thousands of row data.

Thanks in advance.

[Paul_Hossler]

Easy enough but there are some questions about the logic


1. What's difference between Output1 and Output2?

I2 looks like it has data from Row2 and Row3 (Fridge2 and Fridge3??)

H3 only has data from Row3


2. Do you have blank rows (Row4)?


3. Row6 and Row7 have the same input data, but Row6 has an Output2, and Row7 does not



(I turned on Text Wrap so I could see it better)

29501


Edit --

Output1 is easy, although Col D requires some special handling



Option Explicit


Sub MakeSentences()
Dim Output1 As String, Output2 As String
Dim iCol As Long, iRow As Long, iLastRow As Long, i As Long

With Worksheets("Test")
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

For iRow = 2 To iLastRow
Output1 = vbNullString
Output2 = vbNullString

If Len(.Cells(iRow, 1).Value) > 0 Then Output1 = Output1 & .Cells(1, 1).Value & " " & .Cells(iRow, 1).Value & " "
If Len(.Cells(iRow, 2).Value) > 0 Then Output1 = Output1 & .Cells(1, 2).Value & " " & .Cells(iRow, 2).Value & " "
If Len(.Cells(iRow, 3).Value) > 0 Then Output1 = Output1 & .Cells(1, 3).Value & " " & .Cells(iRow, 3).Value & " "
If Len(.Cells(iRow, 4).Value) > 0 Then
i = InStrRev(.Cells(iRow, 4).Value, "=")
Output1 = Output1 & Left(.Cells(1, 4).Value, Len(.Cells(1, 4).Value) - 1) & " "
Output1 = Output1 & Right(.Cells(iRow, 4).Value, Len(.Cells(iRow, 4).Value) - i - 1) & " ) "
End If
If Len(.Cells(iRow, 5).Value) > 0 Then Output1 = Output1 & .Cells(1, 5).Value & " " & .Cells(iRow, 5).Value & " "
If Len(.Cells(iRow, 6).Value) > 0 Then Output1 = Output1 & .Cells(1, 6).Value & " " & .Cells(iRow, 6).Value & " "
If Len(.Cells(iRow, 7).Value) > 0 Then Output1 = Output1 & .Cells(1, 7).Value & " " & .Cells(iRow, 7).Value & " "

.Cells(iRow, 8).Value = Trim(Replace(Output1, " ", " "))
Next iRow

End With
End Sub

[ucan]

Answers are added below the questions. Please have a look.


Easy enough but there are some questions about the logic


1. What's difference between Output1 and Output2?

I2 looks like it has data from Row2 and Row3 (Fridge2 and Fridge3??)

H3 only has data from Row3

Colum A has same IDs based on which I have to get Row2 as shown, and Row3 is thus concatenated form of Row2 out of unique ID.


2. Do you have blank rows (Row4)?

Yes. They may appear below as well before last cell data.


3. Row6 and Row7 have the same input data, but Row6 has an Output2, and Row7 does not

Row6 and Row7 will give same Output1. And So in Output2 I expect only one output.

(I turned on Text Wrap so I could see it better)

29501


Edit --

Output1 is easy, although Col D requires some special handling



Option Explicit


Sub MakeSentences()
Dim Output1 As String, Output2 As String
Dim iCol As Long, iRow As Long, iLastRow As Long, i As Long

With Worksheets("Test")
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

For iRow = 2 To iLastRow
Output1 = vbNullString
Output2 = vbNullString

If Len(.Cells(iRow, 1).Value) > 0 Then Output1 = Output1 & .Cells(1, 1).Value & " " & .Cells(iRow, 1).Value & " "
If Len(.Cells(iRow, 2).Value) > 0 Then Output1 = Output1 & .Cells(1, 2).Value & " " & .Cells(iRow, 2).Value & " "
If Len(.Cells(iRow, 3).Value) > 0 Then Output1 = Output1 & .Cells(1, 3).Value & " " & .Cells(iRow, 3).Value & " "
If Len(.Cells(iRow, 4).Value) > 0 Then
i = InStrRev(.Cells(iRow, 4).Value, "=")
Output1 = Output1 & Left(.Cells(1, 4).Value, Len(.Cells(1, 4).Value) - 1) & " "
Output1 = Output1 & Right(.Cells(iRow, 4).Value, Len(.Cells(iRow, 4).Value) - i - 1) & " ) "
End If
If Len(.Cells(iRow, 5).Value) > 0 Then Output1 = Output1 & .Cells(1, 5).Value & " " & .Cells(iRow, 5).Value & " "
If Len(.Cells(iRow, 6).Value) > 0 Then Output1 = Output1 & .Cells(1, 6).Value & " " & .Cells(iRow, 6).Value & " "
If Len(.Cells(iRow, 7).Value) > 0 Then Output1 = Output1 & .Cells(1, 7).Value & " " & .Cells(iRow, 7).Value & " "

.Cells(iRow, 8).Value = Trim(Replace(Output1, " ", " "))
Next iRow

End With
End Sub

[Paul_Hossler]

Added logic to handle special rules

Also added vbLf to make it easier for me to review - delete if you want




Option Explicit


Sub MakeSentences()
Dim Output1 As String, Output2 As String
Dim iCol As Long, iRow As Long, iLastRow As Long, i As Long, iFruitRow As Long
Dim collFruit As Collection, Fruit As Variant
Dim collOutput2 As Collection, Output2Line As Variant

With Worksheets("Test")
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

For iRow = 2 To iLastRow
Output1 = vbNullString

If Len(.Cells(iRow, 5).Value) = 0 And Len(.Cells(iRow, 6).Value) = 0 And Len(.Cells(iRow, 7).Value) = 0 Then

'The fruit
If Len(.Cells(iRow, 1).Value) > 0 Then Output1 = Output1 & .Cells(iRow, 1).Value & " "

'kept in the
If Len(.Cells(iRow, 3).Value) > 0 Then Output1 = Output1 & .Cells(1, 3).Value & " " & .Cells(iRow, 3).Value & " "

'(got Temperature: )
If Len(.Cells(iRow, 4).Value) > 0 Then
i = InStrRev(.Cells(iRow, 4).Value, "=")
Output1 = Output1 & Left(.Cells(1, 4).Value, Len(.Cells(1, 4).Value) - 1) & " "
Output1 = Output1 & Right(.Cells(iRow, 4).Value, Len(.Cells(iRow, 4).Value) - i - 1) & " ) "
End If

'Output1
.Cells(iRow, 8).Value = Trim(Replace(Output1, " ", " "))

Else
'The fruit
If Len(.Cells(iRow, 1).Value) > 0 Then Output1 = Output1 & .Cells(1, 1).Value & " " & .Cells(iRow, 1).Value & " "

'bought by
If Len(.Cells(iRow, 2).Value) > 0 Then Output1 = Output1 & .Cells(1, 2).Value & " " & .Cells(iRow, 2).Value & " "

'kept in the
If Len(.Cells(iRow, 3).Value) > 0 Then Output1 = Output1 & .Cells(1, 3).Value & " " & .Cells(iRow, 3).Value & " "

'(got Temperature: )
If Len(.Cells(iRow, 4).Value) > 0 Then
i = InStrRev(.Cells(iRow, 4).Value, "=")
Output1 = Output1 & Left(.Cells(1, 4).Value, Len(.Cells(1, 4).Value) - 1) & " "
Output1 = Output1 & Right(.Cells(iRow, 4).Value, Len(.Cells(iRow, 4).Value) - i - 1) & " ) "
End If

', and also got highest mark in
If Len(.Cells(iRow, 5).Value) > 0 Then Output1 = Output1 & .Cells(1, 5).Value & " " & .Cells(iRow, 5).Value & " "

', and also in
If Len(.Cells(iRow, 6).Value) > 0 Then Output1 = Output1 & .Cells(1, 6).Value & " " & .Cells(iRow, 6).Value & ". "

'They got gifts like
If Len(.Cells(iRow, 7).Value) > 0 Then
Output1 = Output1 & .Cells(iRow, 1).Value & " " & .Cells(1, 7).Value & " " & .Cells(iRow, 7).Value & " "
End If

'Output1
.Cells(iRow, 8).Value = Trim(Replace(Output1, " ", " "))

End If

Next iRow


' Output2
'different fruits
Set collFruit = New Collection
For iRow = 2 To iLastRow
On Error Resume Next
collFruit.Add .Cells(iRow, 1).Value, .Cells(iRow, 1).Value
On Error GoTo 0
Next

For Each Fruit In collFruit
Set collOutput2 = New Collection

iFruitRow = 0
For iRow = 2 To iLastRow
If .Cells(iRow, 1).Value = Fruit Then
If iFruitRow = 0 Then iFruitRow = iRow
On Error Resume Next
collOutput2.Add iRow, .Cells(iRow, 8).Value
On Error GoTo 0
End If
Next

Output2 = vbNullString
For Each Output2Line In collOutput2
Output2 = Output2 & .Cells(Output2Line, 8).Value & vbLf & vbLf
Next

.Cells(iFruitRow, 9).Value = Left(Output2, Len(Output2) - 1)
Next
End With


MsgBox "Done"


End Sub