Member Avatar for Jeffrey_1

I am having an impossible time finding a solution for this. I need to combine cell contents in an unusual way (see below), based on if there is an "x" in column A. See below for the exact representation of what I need to do in a worksheet with 200,000 total cells of content. Is there any hope? Anyone who can help will be my personal hero for life, and you may save a life (mine!)!

Current data format

A   B   C   D   E
x   a   l   g   
    b   m   h   Title A
    c   n   i   
x   d   o   j   
    e   p   k   Title B
    f   q   l   Title C
    g   r   m

Needed Format

A   B           C           D           E
x   a b c       l m n       g h i       Title A
x   d e f g     o p q r     j k l m     Title B/Title C
  • 2 Contributors
  • 6 Replies
  • 306 Views
  • 1 Day Discussion Span
  • Latest Post Latest Post by Jeffrey_1

Dani AI

Generated

Brief solution and context for (and thanks to for the attempts): rows with an "x" in column A mark the start of a group; every following row up to the next "x" contributes nonblank values that should be concatenated into that group's row. The macro below does a single, memory-based pass through the sheet (no Select/Activate), builds the concatenated strings per column and writes a compact output sheet. The last column is treated as the "title" column and individual titles are joined with "/" as shown in the thread; that behavior is configurable.

Why this approach: reading the used range into a Variant array and concatenating in VBA memory is orders of magnitude faster than copying columns around or touching cells one-by-one. This makes it appropriate for hundreds of thousands of cells. Always run on a copy of the workbook first.

To use: open the VBA editor (Alt+F11), Insert > Module, paste the code and run the Sub named CombineGroupsByX. If the title column is not the last column, set the variable titleCol in the code to the correct column number. To force a single-column run, limit lastCol to 2 (or the relevant column) before processing.

Option Explicit

Sub CombineGroupsByX()
    Dim ws As Worksheet, outWs As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim rngFind As Range
    Dim data As Variant
    Dim i As Long, j As Long, r As Long
    Dim inGroup As Boolean
    Dim cur() As String
    Dim results As Collection
    Dim grp As Variant
    Dim item As Variant
    Dim outArr As Variant
    Dim outName As String
    Dim titleCol As Long

    Set ws = ActiveSheet
    On Error Resume Next
    Set rngFind = ws.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If rngFind Is Nothing Then Exit Sub
    lastRow = rngFind.Row
    Set rngFind = ws.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
    lastCol = rngFind.Column
    On Error GoTo 0

    data = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Value2
    titleCol = lastCol ' change if title is in a different column

    ReDim cur(1 To lastCol)
    Set results = New Collection
    inGroup = False

    For i = 1 To UBound(data, 1)
        If LCase(Trim(CStr(data(i, 1) & ""))) = "x" Then
            If inGroup Then
                ReDim grp(1 To lastCol)
                grp(1) = "x"
                For j = 2 To lastCol: grp(j) = cur(j): Next j
                results.Add grp
            End If
            inGroup = True
            For j = 2 To lastCol
                If Len(Trim(CStr(data(i, j) & ""))) > 0 Then cur(j) = Trim(CStr(data(i, j))) Else cur(j) = ""
            Next j
        Else
            If inGroup Then
                For j = 2 To lastCol
                    If Len(Trim(CStr(data(i, j) & ""))) > 0 Then
                        If cur(j) = "" Then
                            cur(j) = Trim(CStr(data(i, j)))
                        Else
                            If j = titleCol Then
                                cur(j) = cur(j) & "/" & Trim(CStr(data(i, j)))
                            Else
                                cur(j) = cur(j) & " " & Trim(CStr(data(i, j)))
                            End If
                        End If
                    End If
                Next j
            End If
        End If
    Next i

    If inGroup Then
        ReDim grp(1 To lastCol)
        grp(1) = "x"
        For j = 2 To lastCol: grp(j) = cur(j): Next j
        results.Add grp
    End If

    outName = "Combined"
    On Error Resume Next
    Set outWs = Worksheets(outName)
    On Error GoTo 0
    If outWs Is Nothing Then
        Set outWs = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        outWs.Name = outName
    Else
        outWs.Cells.Clear
    End If

    If results.Count = 0 Then
        outWs.Range("A1").Value = "No groups found"
        Exit Sub
    End If

    ReDim outArr(1 To results.Count, 1 To lastCol)
    For r = 1 To results.Count
        item = results(r)
        For j = 1 To lastCol: outArr(r, j) = item(j): Next j
    Next r

    outWs.Range(outWs.Cells(1, 1), outWs.Cells(results.Count, lastCol)).Value = outArr
    outWs.Columns("A:" & ColLetter(lastCol)).AutoFit
End Sub

Function ColLetter(colNum As Long) As String
    Dim s As String, n As Long
    n = colNum
    Do While n > 0
        s = Chr(((n - 1) Mod 26) + 65) & s
        n = (n - 1) \ 26
    Loop
    ColLetter = s
End Function

Notes: trim and LCase are used so " x " or "X" still work. For de-duplication of titles or different separators, insert simple checks when appending to cur(titleCol). This single-pass macro should be much quicker and less error-prone than copying columns between sheets.

Recommended Answers

All 6 Replies

Member Avatar for Stuugie

Hi Jeffrey, I've been trying to accomplish this as per your first post about this but this is no easy task. Maybe someone will come along and be able to do this quicker than me but who knows.

Edited by Stuugie
Member Avatar for Stuugie

This feels above my understanding and I keep coding myself into circles. Try taking your problem for this question. There's a lot of excellent VBA talent to chose from here (please don't beat me mods). Remember to come back here though, we need your questions.

Edited by Stuugie
Member Avatar for Stuugie

Choose, not chose! Darned rush typing.

Member Avatar for Jeffrey_1

Perhaps I could do this one column at a time by copying the individual columns into seperate sheets, run a Macro, then copy the reformated info back (EG, just do column A and one other column at a time like below). Would this be easier or possible?

Current format

A   B  
x   a 
    b  
    c   
x   d  
    e   
    f   
    g

Needed Format

A   B           
x   a b c      
x   d e f g
Member Avatar for Stuugie

For whatever reason, I just can't make this work properly. I'm still trying though, thought I would let you know.

Member Avatar for Jeffrey_1

Thanks, I appreciate it. Perhaps it's a lost cause :/

Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.