将文本加入不同行和列的一个单元格

Question

我有一个电子表格，其值类似于以下内容：

是否有任何可能的方法来创建 VBA 以将每个 ID 和 Class 的所有单独数据合并为一行？这样最终的结果会像下面这样吗？

Sub JoinRowsData() 
    Dim lastRow As Long, i As Long, j As Long, k As Long
    Application.ScreenUpdating = False

    lastRow = Range("C" & Rows.Count).End(xlUp).Row
    For i = 2 To lastRow
        For j = i + 1 To lastRow 
            If Cells(i, 2) = Cells(j, 2) Then 
                For k = 5 To 10 
                    If (Cells(i, k) = "" And Cells(j, k) <> "") Then 
                        Cells(i, k) = Cells(j, k) 
                    End If 
                Next 
            End If 
        Next 
    Next 

    Application.ScreenUpdating = True 
End Sub

Answer 1

下面会做的。请参阅评论以了解其工作原理。它使用数组来处理数据，比直接处理单元格要快得多。

Option Explicit

Public Sub JoinRowsData()
    Dim ws As Worksheet  ' define worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    Dim LastRow As Long  ' get last used row in worksheet
    LastRow = GetLastUsed(xlByRows, ws)
    
    Dim LastCol As Long  ' get last used column in worksheet
    LastCol = GetLastUsed(xlByColumns, ws)

    ' Read data into an array for faster processing
    Dim Data() As Variant
    Data = ws.Range("A1", ws.Cells(LastRow, LastCol)).Value2
    
    ' define an output array with the same size
    Dim Output() As Variant
    ReDim Output(1 To UBound(Data, 1), 1 To UBound(Data, 2))
    
    Dim outRow As Long  ' output row index

    Dim iRow As Long
    For iRow = 1 To LastRow  ' loop through all rows in data
        ' if column 1 contains data it is a new output row
        If Data(iRow, 1) <> vbNullString Then
            outRow = outRow + 1
        End If
        
        ' loop through all columns in a data row
        Dim iCol As Long
        For iCol = 1 To LastCol
            If Data(iRow, iCol) <> vbNullString Then ' check if current cell has data
                If Output(outRow, iCol) <> vbNullString Then
                    ' add a line break if there is already data in the output cell
                    Output(outRow, iCol) = Output(outRow, iCol) & vbLf
                End If
                
                ' add the data to the output cell
                Output(outRow, iCol) = Output(outRow, iCol) & Data(iRow, iCol)
            End If
        Next iCol
    Next iRow
    
    ' write all the output data from the array back to the cells
    ws.Range("A1", ws.Cells(LastRow, LastCol)).Value2 = Output
End Sub


' find last used row or column in worksheet
Public Function GetLastUsed(ByVal RowCol As XlSearchOrder, ByVal InWorksheet As Worksheet) As Long
    With InWorksheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            Dim LastCell As Range
            Set LastCell = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=RowCol, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False)
            If RowCol = xlByRows Then
                GetLastUsed = LastCell.Row
            Else
                GetLastUsed = LastCell.Column
            End If
        Else
            GetLastUsed = 1
        End If
    End With
End Function

将文本加入不同行和列的一个单元格

Join text into one cell in various row and column

excel

vba

excel-formula