VBA - сопоставить непустые значения ячеек с новым столбцом

Question

У меня есть проект на VBA, где я хочу сопоставить некоторое непустое значение строки с самым последним столбцом той же строки, и мне нужно сгруппировать эти значения в подмножестве.Возможно, это утверждение может вводить в заблуждение, поэтому я прилагаю также скриншот с формулировкой проблемы.

Исходные данные

Окончательные данные

Я мог бы работать даже с приведенным ниже выводом

Вот код, который я пробовал до сих пор:

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

Почему-то это тоже не работает.

РЕДАКТИРОВАТЬ : С помощью я могу разместить vbCrLf.

Все еще нужна помощь для получения желаемого результата.

Дайте мне знать, если какие-либо другие детали могут бытьпредусмотрено в том же?

Answer 1

Если я понял ваш вопрос, я попробовал этот код и работает ...

сначала я начну с этих данных в листе

выполнить код VBA и после того, как я получу

это код, который я попробовал:

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

Надеюсь, это поможет

РЕДАКТИРОВАТЬ ПОСТ после вашего комментария.Вы можете использовать inputBox ... обновить макрос следующим образом:

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

Вставьте номер столбца, с которого вы хотите начать, если вы хотите больше контроля ввода, вы должны проанализировать ввод, например, если первый вводis fruit :, vegetable: и так далее ... isNumeric второй вход ...

Answer 2

Следующий код создает новую рабочую таблицу для вывода, определяет заголовки и преобразует данные:

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

Пример рабочей книги

Answer 3

Это было бы просто If InStr(1, result, cellValue, vbTextCompare) = 0 Then result = result & cellValue & vbCrLf