Concatenate macro based on merged cell value

[agr22]

Thanks for any help!

I am trying to speed up a process for my job where instead of copying and pasting all of the values into one field, I can run a macro to put it all into one field for me.

How the field comes to me is with a merged cell of "Responsibility / Duty:" and all the fields to the right need to be included. Then there could be a few rows in between and needs to have all of those values included as well.

	1
Responsibility / Duty:	2
	3
Other field
	1
Responsibility / Duty:	2
	3

<tbody>
</tbody>

I've pulled a concatinate all cell values function, but it's selecting the range of cells that I'm unsure the best method of doing. Any help is appreciated!

Function ConcatinateAllCellValuesInRange(sourceRange As Excel.Range) As String    
    Dim finalValue As String
    Dim cell As Excel.Range
    
    For Each cell In sourceRange.Cells        
        finalValue = finalValue + CStr(cell.Value) + Chr(10)            
    Next cell

    ConcatinateAllCellValuesInRange = finalValue
End Function

 

[agr22]

For any wondering how I did this... or for any tips on cleaning this up

Function ConcatinateAllCellValuesInRange(sourceRange As Excel.Range) As String    
    Dim finalValue As String
    Dim cell As Excel.Range


    For Each cell In sourceRange.Cells
        finalValue = finalValue + CStr(cell.Value) + Chr(10)
    Next cell


    ConcatinateAllCellValuesInRange = finalValue
    
End Function


Sub Combine()
'
' Combine Macro
'
    Dim myRange As Range        'testing to add a range
    
    Dim posWS As Worksheet      ' Position Description worksheet
    Dim resp As String          ' to set the "Responsibility / Duty:" field
    Dim respTotal As Integer    ' this value is the total number of times resp occurs
    Dim textToInput As String
    Dim offsetRange As Range
    
    Dim cell
    Dim c As Range
    


    ' setting the worksheet to the Position Description and finding all the occurances of "Responsibility / Duty:"
    Set posWS = ThisWorkbook.Sheets("Position Description")
    resp = "Responsibility / Duty:"
    respTotal = Application.CountIf(posWS.Range("A:A"), resp)




    'combines all of the fields with "Responsibility / Duty:" into one field
    If respTotal <> 0 Then ' only if there are responsibilites listed will it combine the values
        
        Dim iCount As Integer
        iCount = 0
        textToInput = ""
        
        
        With posWS.Range("A:A")
            Set c = .Find(resp, LookIn:=xlValues)
            
            If Not c Is Nothing Then
                Do  'the loop that looks for each of the resp cells
                    iCount = iCount + 1 'loops through until respTotal


                    'takes the merged cell and then offsetting them to the cells to the right (including each additional row)
                    Set offsetRange = posWS.Range(posWS.Range(c.MergeArea.Address).Offset(0, 1).Address & ":" & _
                        posWS.Range(c.MergeArea.Cells(c.MergeArea.Rows.Count, c.MergeArea.Columns.Count).Address).Offset(0, 1).Address)
                    textToInput = textToInput & ConcatinateAllCellValuesInRange(offsetRange)


                    'MsgBox "icount:" & iCount & Chr(10) & _
                        "range address: " & posWS.Range(c.MergeArea.Address).Address & Chr(10) & _
                        "offset address: " & offsetRange.Address & Chr(10) & _
                        "String: " & textToInput


                    Set c = .FindNext(c)
                    Loop While iCount <> respTotal
            End If
        End With


    End If
    
    'setting the value in the spreadsheet
    ActiveSheet.Range("B21").Value = textToInput


   
End Sub

 

[Mike Szczesny]

Please let me know if you are interested in a non-macro solution. Personally, I do not work with macros.