Вложенные для петли альтернативы или оптимизация

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