Question

当前尝试将每行中的所有单元格附加到该行的第一个单元格中，并遍历每行。问题是我正在处理〜3000行，每行约有20列数据。有没有更好的方法可以将一行中的所有单元格附加到一个单元格中而不使用for循环？这样可以将代码缩小为单个for循环，并可以加快处理速度。

试图制作一个嵌套的for循环，该循环循环遍历每一行，然后遍历每一行的每一列。它可以工作，但是在处理大量数据时会花费太长时间。

Sub AppendToSingleCell()

Dim value As String
Dim newString As String
Dim lastColumn As Long
Dim lastRow As Long


lastRow = Cells(Rows.Count, "A").End(xlUp).Row

For j = 1 To lastRow

    lastColumn = Cells(j, Columns.Count).End(xlToLeft).Column

    For i = 2 To lastColumn

     If IsEmpty(Cells(j, i)) = False Then
            value = Cells(j, i)
            newString = Cells(j, 1).value & " " & value
            Cells(j, 1).value = newString
            Cells(j, i).Clear
        End If

    Next i

Next j


End Sub

Answer 1

将所有内容加载到变量数组中，并循环而不是范围。将输出加载到另一个变量数组中，然后将该数据放回表中。

Sub AppendToSingleCell()

    With ActiveSheet

        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).row

        Dim lastColumn As Long
        lastColumn = .Cells.Find(What:="*", After:=.Range("a1"), LookIn:=xlValue, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

        Dim dtaArr() As Variant
        dtaArr = .Range(.Cells(1, 2), .Cells(lastRow, lastColumn)).value

        Dim otArr() As Variant
        ReDim otArr(1 To lastRow, 1 To 1)

        Dim i As Long
        For i = LBound(dtaArr, 1) To UBound(dtaArr, 1)
            For j = LBound(dtaArr, 2) To UBound(dtaArr, 2)
                If dtaArr(i, j) <> "" Then otArr(i, 1) = otArr(i, 1) & dtaArr(i, j) & " "
            Next j
            otArr(i, 1) = Application.Trim(otArr(i, 1))
        Next i

        .Range(.Cells(1, 2), .Cells(lastRow, lastColumn)).Clear
        .Range(.Cells(1, 1), .Cells(lastRow, 1)).value = otArr

    End With


End Sub

Answer 2

有点长，但是挺简单的。代码注释中的解释。

代码

Option Explicit    

Sub AppendToSingleCell()

Dim newString As String
Dim LastRow As Long, LastColumn As Long
Dim Sht As Worksheet
Dim FullArr As Variant, MergeCellsArr As Variant
Dim i As Long, j As Long

Set Sht = ThisWorkbook.Sheets("Sheet1") ' <-- rename "Sheet1" to your sheet's name    
With Sht
    LastRow = FindLastRow(Sht) ' call sub that finds last row
    LastColumn = FindLastCol(Sht) ' call sub that finds last column

    ' populate array with enitre range contents
    FullArr = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))        
    ReDim MergeCellsArr(1 To LastRow) ' redim 1-D array for results (same number of rows as in the 2-D array)

    ' looping through array is way faster than interfacing with your worksheet
    For i = 1 To UBound(FullArr, 1) ' loop rows (1st dimension of 2-D array)
        newString = FullArr(i, 1)
        For j = 2 To UBound(FullArr, 2) ' loop columns (2nd dimension of 2-D array)
            If IsEmpty(FullArr(i, j)) = False Then
                newString = newString & " " & FullArr(i, j)
            End If
        Next j

        MergeCellsArr(i) = newString ' read new appended string to new 1-D array
    Next i

    ' paste entire array to first column
    .Range("A1").Resize(UBound(MergeCellsArr)).value = MergeCellsArr    
End With

End Sub

'============================================== =======================

Function FindLastCol(Sht As Worksheet) As Long    
' This Function finds the last col in a worksheet, and returns the column number

Dim LastCell As Range

With Sht
    Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
    If Not LastCell Is Nothing Then
        FindLastCol = LastCell.Column
    Else
        MsgBox "Error! worksheet is empty", vbCritical
        Exit Function
    End If
End With

End Function

'============================================== =======================

Function FindLastRow(Sht As Worksheet) As Long    
' This Function finds the last row in a worksheet, and returns the row number

Dim LastCell As Range

With Sht
    Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
    If Not LastCell Is Nothing Then
        FindLastRow = LastCell.Row
    Else
        MsgBox "Error! worksheet is empty", vbCritical
        Exit Function
    End If
End With

End Function

Answer 3

如果您对更短的解决方案感兴趣......假定您的数据始于单元格A1。

Public Sub CombineColumnData()

    Dim arr As Variant
    Dim newArr() As Variant
    Dim varTemp As Variant
    Dim i As Long

    arr = ActiveSheet.Range("A1").CurrentRegion.Value
    ReDim newArr(1 To UBound(arr, 1))

    For i = LBound(arr, 1) To UBound(arr, 1)
        varTemp = Application.Index(arr, i, 0)
        newArr(i) = Join(varTemp, "")
    Next i

    With ActiveSheet.Range("A1")
        .CurrentRegion.Clear
        .Resize(UBound(arr, 1), 1) = Application.Transpose(newArr)
    End With

End Sub

嵌套的For Loop替代方案或优化

3 个答案: