Macro only working on first 3900 rows

[criminal_ginger]

I am using a macro I found online to concatenate data into groups as shown here: How to concatenate cell values until if finds a blank cell in a column?

The macro is as follows:

Sub Concatenatecells()
'updateby Extendoffice
    Dim xRg As Range
    Dim xSaveToRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xTStr As String
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please selecte the data range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    If xRg.Columns.Count > 1 Then
        MsgBox "the selected range is more than one column", vbInformation, "Kutools for Ecel"
        Exit Sub
    End If
    Set xSaveToRg = Application.InputBox("Please selecte output cell:", "Kutools for Excel", , , , , , 8)
    If xSaveToRg Is Nothing Then Exit Sub
    Set xSaveToRg = xSaveToRg.Cells(1)
    Application.ScreenUpdating = False
    For Each xCell In xRg
        If xCell <> "" Then
            xTStr = xTStr & xCell & " "
        Else
            xSaveToRg.Value = xTStr
            Set xSaveToRg = xSaveToRg.Offset(1)
            xTStr = ""
        End If
    Next
    If xTStr <> "" Then xSaveToRg.Value = Left(xTStr, Len(xTStr) - 1)
    Application.ScreenUpdating = True
End Sub

I have about 61,000 rows of data that I am trying to use this function on, but it only outputs the data for about 3,900 rows. Is there anything I can adjust to make this work properly? I am very new to VBA, and I'm completely confused.

 

[Akuini]

Another option to try:

Sub criminal_ginger_1()
Dim i As Long, n As Long
Dim tx As String
Dim va, vb, t
t = Timer
n = Range("F" & Rows.Count).End(xlUp).Row
va = Range("F1:F" & n + 1)
ReDim vb(1 To UBound(va, 1), 1 To 1)
    For i = 1 To UBound(va, 1)
        If va(i, 1) <> "" Then
           If tx = "" Then h = i
           tx = tx & " " & va(i, 1)
        Else
            If tx <> "" Then vb(h, 1) = Mid(tx, 2): tx = ""
        End If
    Next
Range("G1").Resize(UBound(vb, 1), 1) = vb
Debug.Print "It's completed in:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

 

[jolivanes]

You might have time for a coffee break while it runs.

Sub Try_So()
Dim myAreas As Areas, i As Long
Application.ScreenUpdating = False
Set myAreas = ActiveSheet.Columns(6).SpecialCells(2).Areas
    For i = 1 To myAreas.Count
        Cells(i, 7).Value = Join(Application.Transpose(Range(myAreas(i).Cells(1).Resize(myAreas(i).Rows.Count).Address)), " ")
    Next i
Application.ScreenUpdating = True
End Sub

 

[criminal_ginger]

Try this code. It does not loop thru each cell, but area, may help code faster:


View attachment 97963

Option Explicit
Sub concate()
Dim lr&, i&, rng, res(1 To 10, 1 To 10), data As Range, block As Range, st As String
lr = Cells(Rows.Count, "F").End(xlUp).Row
Set data = Range("F1:F" & lr).SpecialCells(xlCellTypeConstants) ' range with value only
For Each block In data.Areas ' loop thru each non-blank ares
    rng = Application.Transpose(block.Value) ' convert from vertical to horizontal range in order to to use "Join"
    If block.Count > 1 Then
        st = Join(Application.Index(rng, 1, 0), " ")
    Else
        st = rng
    End If
    block.Cells(1, 1).Offset(0, 1).Value = st
Next
End Sub

Thank you, that definitely gives me what I want, but it seems to freeze up my Excel after a few seconds. On the bottom right, it switches back and forth from Calculating (8 threads) 0% to Calculating (8 threads) 94%, but then gets stuck at the 94% and Excel becomes non responsive.

 

[criminal_ginger]

Another option to try:

Sub criminal_ginger_1()
Dim i As Long, n As Long
Dim tx As String
Dim va, vb, t
t = Timer
n = Range("F" & Rows.Count).End(xlUp).Row
va = Range("F1:F" & n + 1)
ReDim vb(1 To UBound(va, 1), 1 To 1)
    For i = 1 To UBound(va, 1)
        If va(i, 1) <> "" Then
           If tx = "" Then h = i
           tx = tx & " " & va(i, 1)
        Else
            If tx <> "" Then vb(h, 1) = Mid(tx, 2): tx = ""
        End If
    Next
Range("G1").Resize(UBound(vb, 1), 1) = vb
Debug.Print "It's completed in:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

This worked perfectly, and super quick! Thank you!

 

[Akuini]

This worked perfectly, and super quick! Thank you!

You're welcome, glad to help & thanks for the feedback.