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.

 

[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.

The output of the macro puts all the data into one cell, so I'm wondering if I'm reaching my character limit, and if so, how do I fix this?

 

[Michael M]

The total number of characters that a cell can contain is 32,767. A cell can only display 1,024 characters. At the same time, the Formula bar can show all 32,767 symbols.
Why would you want such a large amount of data in one cell ??

 

[criminal_ginger]

The total number of characters that a cell can contain is 32,767. A cell can only display 1,024 characters. At the same time, the Formula bar can show all 32,767 symbols.
Why would you want such a large amount of data in one cell ??

I actually don't really want all of the data in a single cell, it would be great if it could split like it shows on the webpage I linked. I just have no experience with VBA, and I'm not sure why the code is doing what it is.

 

[Michael M]

In that case you will have to provide example data of what you actually want to happen....a before and after perhaps.

 

[criminal_ginger]

Currently my data is in column F. I would like for it to look like column G. It would also be fine if there weren't empty rows between each set of words, but I'd prefer it to look exactly like G.

 

[Michael M]

Maybe this way then. It assumes blocks of 3 texts

Sub MM1()
 Dim r As Long
 Application.ScreenUpdating = False
 For r = 1 To Cells(Rows.Count, "F").End(xlUp).Row
 If Cells(r, 6) <> "" Then
  Cells(r, 7) = Cells(r, 6)
  Cells(r, 7) = Cells(r, 7) & " " & Cells(r + 1, 6)
  Cells(r, 7) = Cells(r, 7) & " " & Cells(r + 2, 6)
  r = r + 2
End If
 Next r
 Application.ScreenUpdating = True
End Sub

 

[criminal_ginger]

Thank you, I think I've got it figured out! One other question. When I run the macro for all 61000 rows, the bottom of the excel says Calculating (8 threads) 94%, but it doesn't change. How long should I expect this to take? I'm on a mac, and it says the application is not responding, but I don't know if I should wait it out or not

 

[Michael M]

How long has it taken so far ??

 

[bebo021999]

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

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