Please, Head's Spinning - How to Concatanate This? Excel 07 VBA

[SirSchiz]

Any help is so much appreciated with this! My VBA Skills are offically Strained!

I have many worksheets that have a data structure like this:

Sample Data for testing:

X1
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
X1
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppp
X1
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppp
X1
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppp
X1
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp

BTW..All Data in all worksheets is in Column A

I need the the first found X1 to the Next Found X1 copied over to column D and combined(Concatenate right?) into 1 cell. Then repeated, but the next section would copy and combine to the next cell available in column D each section separated by a empty cell until all sections are complete. Then Next worksheet. The code I have so far copies only the first found section and copies, but very poorly combines into one cell.

My Sad Code:

Sub FindIt()

Dim Term As String
Dim Var As Range
Dim NxWsht As Worksheet
Dim WkBk As Workbook

    Term = "X1"
    Set Var = Range("A:A").Find(What:=Term, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
    SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    Set WkBk = ActiveWorkbook
    
For Each NxWsht In WkBk.Sheets
    ActiveSheet.Range(Var, Var.End(xlUp)).Select
        With Selection
            .Copy
            .Range("D:D").PasteSpecial xlValues
        End With
            Set rng = Selection
            Set cel = Cells.Value
            For Each cel In rng
            x = x & cel.Value
            Next
            ActiveSheet.Range("D:D").Value = x
    
    Set Var = Range("A:A").FindNext([A1])

Next NxWsht

End Sub

 

[AlphaFrog]

Sub FindIt()

    Dim Term As String, strTemp As String
    Dim NxWsht As Worksheet
    Dim rng As Range, rngArea As Range, cell As Range
    Dim Lastrow As Long

    Term = "X1"
    Application.ScreenUpdating = False

    Set NxWsht = ActiveSheet ' For testing on only one sheet
    'For Each NxWsht In ActiveWorkbook.Sheets
        With NxWsht
        
            Lastrow = .Range("A" & Rows.Count).End(xlUp).Row                        'Last used row in column A
            .Range("A1:A" & Lastrow).AutoFilter Field:=1, Criteria1:="<>" & Term    'Hide (autofilter) all rows with Term
            Set rng = .Range("A2:A" & Lastrow).SpecialCells(xlCellTypeVisible)      'Define visible result cells
            .AutoFilterMode = False                                                 'Clear autofilter
            
            For Each rngArea In rng.Areas                                           'Loop through each Area (contiguous cells)
                strTemp = vbNullString                                              'Reset concatenated string
                For Each cell In rngArea                                            'Loop through each cell in a given area
                    strTemp = strTemp & cell.Value & vbLf                           'Concatenate strings from each cell in a given area
                Next cell
                strTemp = Left(strTemp, Len(strTemp) - 1)                           'remove trailing line feed character
                .Range("D" & Rows.Count).End(xlUp).Offset(2).Value = strTemp        'Concatenated string to the next empty row in column D (empty cells in between)
            Next rngArea
            
            .Range("D:D").ColumnWidth = 200                                         'Autofit rows and columns
            .Range("D:D").Columns.AutoFit                                           '
            .Cells.Rows.AutoFit                                                     '
        
        End With
    'Next NxWsht
    Application.ScreenUpdating = True

End Sub

 

[cgcamal]

Hi SirSchiz,

Another option, that almost need that you extend it to work for all workbooks, currently works for all worksheets in current book.

Sub FindIt()
Dim SectionsRow()
Dim Term As String, s As Integer
Dim Var As Integer, TermCount As Integer, i As Integer
Dim NxWsht As Worksheet
Dim WkBk As Workbook

Application.ScreenUpdating = False
    Term = "X1"
    
    'Set WkBk = ActiveWorkbook
    
For s = 1 To Sheets.Count

With Sheets(s)
    TermCount = WorksheetFunction.CountIf(.Range("A:A"), Term)
    Var = .Range("A65000").End(xlUp).Row
    .Cells(Var + 1, 1) = Term
    
    ReDim SectionsRow(1 To TermCount + 1)
    
    SectionsRow(TermCount + 1) = Var + 1
    
    For i = TermCount To 1 Step -1
        Var = .Range("A:A").Find(What:=Term, After:=.Range("A" & Var), LookIn:=xlFormulas, LookAt:=xlPart, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    
        SectionsRow(i) = Var
    Next

    For i = LBound(SectionsRow) To UBound(SectionsRow) - 1
        For j = SectionsRow(i) + 1 To SectionsRow(i + 1) - 1
            .Cells(i, 4) = .Cells(i, 4) & "-" & .Cells(j, 1)
        Next
    Next
.Cells(SectionsRow(TermCount + 1), 1).ClearContents

End With
Next s

Application.ScreenUpdating = True
End Sub

Hope this helps,

Regards.

 

[Rick Rothstein]

Give this code a try...

Sub CopyX1DataInColumnAtoColumnD()
  Dim RW As Long, A As Range, WS As Worksheet
  Const Term As String = "X1"
  Application.ScreenUpdating = False
  For Each WS In Worksheets
    RW = 1  ' Row with first "X1" in it
    If WS.Cells(RW, "A").Value = Term Then
      WS.Columns("A").Replace Term, "", xlWhole
      For Each A In WS.Columns("A").SpecialCells(xlCellTypeConstants).Areas
        WS.Cells(RW, "D").Value = Join(WorksheetFunction.Transpose(A.Cells), vbLf)
        RW = RW + 2
      Next
      WS.Columns("A").SpecialCells(xlCellTypeBlanks).Value = Term
    End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[SirSchiz]

AlphaFrog,

Thanks for your reply! This is very close to what I'm trying to do. I may have miss spoke. Is there a way to copy the contents between each X1 to 1 combined cell for each group? Meaning, 1st X1 to Next then copy that to D1, then the next X1 to its next occurrence and copy this group to cell D3 and so on.
Example:

From This - To This

[U]Column A [/U]                   [U]Column D[/U]
X1                                      
ppppppppp                           pppppppppppp CELL D1
ppppppppp                           pppppppppppp
X1            
ppppppppp                           pppppppppppp
ppppppppp                           pppppppppppp Cell D3
X1
ppppppppp                          pppppppppppp Cell D5

 

[AlphaFrog]

Sub FindIt()

    Dim Term As String, strTemp As String
    Dim NxWsht As Worksheet
    Dim rng As Range, rngArea As Range, cell As Range
    Dim Lrow As Long

    Term = "X1"
    Application.ScreenUpdating = False

    'Set NxWsht = ActiveSheet ' For testing on only one sheet
    For Each NxWsht In ActiveWorkbook.Sheets
        With NxWsht
        
            Lrow = .Range("A" & Rows.Count).End(xlUp).Row                           'Last used row in column A
            .Range("A1:A" & Lrow).AutoFilter Field:=1, Criteria1:="<>" & Term       'Hide (autofilter) all rows with Term
            Set rng = .Range("A2:A" & Lrow).SpecialCells(xlCellTypeVisible)         'Define visible result cells
            .AutoFilterMode = False                                                 'Clear autofilter
            Lrow = 1
            For Each rngArea In rng.Areas                                           'Loop through each Area (contiguous cells)
                strTemp = vbNullString                                              'Reset concatenated string
                For Each cell In rngArea                                            'Loop through each cell in a given area
                    strTemp = strTemp & cell.Value & vbLf                           'Concatenate strings from each cell in a given area
                Next cell
                strTemp = Left(strTemp, Len(strTemp) - 1)                           'remove trailing line feed character
                .Range("D" & Lrow).Value = strTemp                                  'Concatenated string to the next empty row in column D (empty cells in between)
                Lrow = Lrow + 2
            Next rngArea
            
            .Range("D:D").ColumnWidth = 200                                         'Autofit rows and columns
            .Range("D:D").Columns.AutoFit                                           '
            .Cells.Rows.AutoFit                                                     '
        
        End With
    Next NxWsht
    Application.ScreenUpdating = True

End Sub

 

[SirSchiz]

cgcamal,

Your's is it! I just realized that yours is doing just what I'm looking for. The formatting was off a bit. I will play with it to see if I can get each cell to wrap text. Thank You!

Rick - You looks very efficient. Unfortunately I could not get it to work. It would flash the screen, but nothing would happen on the sheet.

AlphaFrog, thanks again. I wonder if I could use a section of your code to adjust the formatting? Anyways, thank you all for your efforts. It doesn't go unnoticed!

 

[SirSchiz]

AlphaFrog,

Thanks for re-posting. I tried this again, and it looks good, I really like the fact you considered the formating.However its just not breaking up up each section into 1 cell each. It's just combining all the contents in -between each X1 into Cell D1 only.

 

[AlphaFrog]

I guees I don't follow.

Before macro...
<br /><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>A</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style=";">X1</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style=";">X1</td></tr><tr ><td style="color: #161120;text-align: center;">6</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">7</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">8</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">9</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">10</td><td style=";">ppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">11</td><td style=";">X1</td></tr><tr ><td style="color: #161120;text-align: center;">12</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">13</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">14</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">15</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">16</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">17</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">18</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">19</td><td style=";">ppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">20</td><td style=";">X1</td></tr><tr ><td style="color: #161120;text-align: center;">21</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">22</td><td style=";">pppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">23</td><td style=";">X1</td></tr><tr ><td style="color: #161120;text-align: center;">24</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">25</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">26</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">27</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">28</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">29</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr></tbody></table><br /><br />

Result...
<br /><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color: #E0E0F0" /><col /></colgroup><thead><tr style=" background-color: #E0E0F0;text-align: center;color: #161120"><th></th><th>D</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">1</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">2</td><td style="text-align: right;;"></td></tr><tr ><td style="color: #161120;text-align: center;">3</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">4</td><td style="text-align: right;;"></td></tr><tr ><td style="color: #161120;text-align: center;">5</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">6</td><td style="text-align: right;;"></td></tr><tr ><td style="color: #161120;text-align: center;">7</td><td style=";">pppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppp</td></tr><tr ><td style="color: #161120;text-align: center;">8</td><td style="text-align: right;;"></td></tr><tr ><td style="color: #161120;text-align: center;">9</td><td style=";">ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
pppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp
ppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppppp</td></tr></tbody></table><br /><br />

What am I missing?

 

[Rick Rothstein]

Rick - You looks very efficient. Unfortunately I could not get it to work. It would flash the screen, but nothing would happen on the sheet.

I'm not sure what to tell you... I tested the code before I posted it and it worked fine against my example data (which I copy/paste'd from your posting). The only thing I can think of is if your "X1" cells have more than the characters "X1" in them. By the way, that is a "one" and not a lower case "el" after the "X", right?). Perhaps there are leading/trailing blank spaces or non-breaking spaces (ASCII code 160) in the cell along with those characters. As I said, I know the code works (I just tested it again to be sure), but your data (at least the X1 part of it) must be what you showed us it to be.