CODEWITHSUNDEEP
excelvba
desmond.carros
desmond.carros

Reputation: 362

VBA - Collate non empty cell values to a new column

I have a project on VBA where i want to collate some non empty value of a row to the very last column of the same row, and i have to group those values in a subset. Maybe, the statement could be misleading, hence i am attaching a screenprint of the problem statement as well.

Initial Data

Initial Data

Final Data

Final Data

I Could even work with the below output

enter image description here

Here is the code that i have tried so far : 

Sub project()
Dim ConcatItNoDuplicities As String
Dim cellsToConcat As Range
    ConcatItNoDuplicities = ""
    If cellsToConcat Is Nothing Then Exit Sub
    Dim oneCell As Range
    Dim result As String
    For Each oneCell In cellsToConcat.Cells
        Dim cellValue As String
        cellValue = Trim(oneCell.Value)
        If cellValue <> "" Then
            If InStr(1, result, cellValue, vbTextCompare) = 0 Then result = result & cellValue & vbCrLf
        End If
    Next oneCell
    If Len(result) > 0 Then result = Left(result, Len(result) - 1)
    ConcatItNoDuplicities = result
End Sub

Somehow this is not working as well.

EDIT : With help i could place vbCrLf.

Still need help to obtain desired output.

Let me know if any other details can be provided in the same?

Upvotes: 0

Views: 169

Answers (3)

Ferdinando
Ferdinando

Reputation: 964

If i understood your question i have tried this code and works...

first i start with this data into sheet enter image description here

execute the vba code and after i get enter image description here

this is the code that i have tried:

Sub test()

Dim item As String

'search fruit:
item = "fruit:"
Call myControl(item, 6) '6 start from column F

'search vegetable:
item = "vegetable:"
Call myControl(item, 7) '7 start from column G

'search grains:
item = "grains:"
Call myControl(item, 8) '8 start from column H

End Sub

Function myControl(ByVal searchItem As String, startColumn)

Dim numColumns, numRows, colStart, endCol, i, c As Long
Dim allTogether As String

allTogether = "" 'this variable will contain all the items ex. fruit or vegetable or grains

'how many columns there are...
numColumns = Cells(1, Columns.count).End(xlToLeft).Column

'how many rows there are...
numRows = Cells(rows.count, "A").End(xlUp).Row

'start from column (the first time is column F after first control start from Column G and so on..)
'colStart = startColumns
endCol = 0

'control how many searchItem there are in the columns
For i = startColumn To numColumns

    If (InStr(Cells(1, i), searchItem) <> 0) Then

        endCol = i

    Else
        i = numColumns + 1
    End If
Next i

If endCol <> 0 Then

    For i = 2 To numRows

        For c = startColumn To endCol

            If (Cells(i, c) <> "") Then

                allTogether = allTogether & " " & Cells(i, c)

            End If
        Next c
        Cells(i, startColumn) = allTogether 'get the element all together (ex. fruit)
        allTogether = ""
    Next i

'delete the columns that i have ragruppated
Range(Cells(1, startColumn + 1), Cells(numRows, endCol)).Delete shift:=xlToLeft
End If

End Function

Hope this helps

EDIT POST after your comment. You can use the inputBox... update the macro in this way:

Sub test()

Dim item As String
Dim col As Long

'search fruit:
item = InputBox("Insert the item") ' example fruit: or vegetable: and so on...

col=InputBox("Insert the column number where you want to start") '6 start from column F
Call myControl(item, col) 

End Sub

Insert the column number where you want to start if you want more input control you have to analyze input for example if the first input is fruit:, vegetable: and so on... isNumeric the second input...

Upvotes: 1

JohnyL
JohnyL

Reputation: 7142

The following code creates new worksheet for output, defines headers and transforms data:

Sub Transform()

    Dim wksOutput As Worksheet
    Dim wksSource As Worksheet
    Dim dic, dic2, r, c, x, key, arr, last_col

    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    Set wksSource = Sheets("source")
    '// Create output worksheet
    Set wksOutput = Sheets.Add(After:=Sheets(Sheets.Count))

    With wksSource

        '// Get headers
        last_col = .Range("A1").End(xlToRight).Column
        For c = 6 To last_col
            dic(Split(.Cells(1, c), ":")(0) & ":") = 1 '//Don't care the value
        Next

        '// Copy data that doesn't change (columns A:E)
        .Range("A1").CurrentRegion.Resize(, 5).Copy wksOutput.Cells(1)
        '// Output headers
        For Each key In dic.Keys()
            x = x + 1
            wksOutput.Cells(1, 5 + x).Value = key
        Next

        For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            dic2.RemoveAll
            '// Process each row
            For c = 6 To last_col
                x = .Cells(r, c)
                If Len(x) > 0 Then
                    '// Split value and assign concatenated
                    '// value back to dictionary
                    arr = Split(x, ":")
                    dic2(arr(0)) = dic2(arr(0)) & IIf(dic2.Count > 0, Chr(10), "") & arr(0) & ":" & arr(1)
                End If
            Next
            '// Get dictionary key which is header,
            '// find column by this header and assign value to cell.
            For Each key In dic2.Keys()
                wksOutput.Cells(r, wksOutput.Rows(1).Find(key).Column) = dic2(key)
            Next
        Next

    End With

End Sub

Sample workbook

Upvotes: 1

Michal
Michal

Reputation: 5857

It would be just If InStr(1, result, cellValue, vbTextCompare) = 0 Then result = result & cellValue & vbCrLf

Upvotes: 1

Related Questions