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

那只是If InStr(1, result, cellValue, vbTextCompare) = 0 Then result = result & cellValue & vbCrLf

Answer 2

如果我理解了您的问题，我已经尝试了此代码并可以工作...

首先，我将这些数据放入表格

执行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

将列号插入要开始的位置如果您想要更多的输入控件，则必须分析输入，例如，如果第一个输入是水果：，蔬菜：等等... isNumeric第二个输入...

Answer 3

以下代码为输出创建新的工作表，定义标题并转换数据：

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

VBA-将非空单元格值整理到新列

3 个答案: