Concatenate rows into a single line by VBA

[pjmsimmons]

Hi All,
I have two columns of data H & N in a worksheet 'Sample Details' and I am looking for some code that will do the following. Unfortunately its outside of my present skill set with VBA.

For each selected X in a sample worksheet concatenate the data in x.offset (0,6) and x.offset (0,12) onto a single line (space between the concatenated data) and each concatenation separated by a semicolon e.g. on a different worksheet 'Text message'

eg

1) the data is presented thus on worksheet 'Sample Details'. (numbers should be under column 7 and UTD/NUTD under column 13 on the example below).

Column 1.........Column 7.............Column 13
A 1234 UTD
A 2356 UTD
A 7521 NUTD
A A345 UTD
B 4589 UTD
B 1256 NUTD



I select each row marked A in column 1 and the code would concatenate the four lines as follows and places it in the next available row in column B on the worksheet 'Text message'

1234 UTD; 2356 UTD, 7521 NUTD, A345 UTD

I then select each row marked B in column 1 and the process is repeated such that the following would now appear on the worksheet 'Text Message'

1234 UTD; 2356 UTD, 7521 NUTD, A345 UTD
4589 UTD; 1256 NUTD


I hope someone can help as I'm stuck at the moment .

regards,

Paul

 

[MickG]

Try This:-
NB:- Column 7 is "G" and column "13" is "M", not "H & N"

[COLOR="Navy"]Sub[/COLOR] MG31Jan45
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sample Details")
    [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Resize(Rng.Count + 1)
    [COLOR="Navy"]If[/COLOR] Not Temp = Dn And Not oStr = "" [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Sheets("Text message").Range("B" & c) = Mid(oStr, 2)
        oStr = ""
        oStr = oStr & ";" & Dn.Offset(, 6) & " " & Dn.Offset(, 12)
    [COLOR="Navy"]Else[/COLOR]
        oStr = oStr & ";" & Dn.Offset(, 6) & " " & Dn.Offset(, 12)
    [COLOR="Navy"]End[/COLOR] If
        Temp = Dn
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[pjmsimmons]

Hi Mick,
Firstly, thanks for taking the time to help.

I tried your code and its not quite there yet

This is the result I get back:

	;
	; ; ; ; ;
	Animal Tag Number Result

<colgroup><col><col span="3"></colgroup><tbody>
</tbody>

I should make it clear that the initial selection is actually column B and that column 7 in my post therefore does represent H & N. Sorry for that confusion.

Paul

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG01Feb23
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sample Details")
    [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Resize(Rng.Count + 1)
    [COLOR="Navy"]If[/COLOR] Not Temp = Dn And Not oStr = "" [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        Sheets("Text message").Range("B" & c) = Mid(oStr, 2)
        oStr = ""
        oStr = oStr & ";" & Dn.Offset(, 6) & " " & Dn.Offset(, 12)
    [COLOR="Navy"]Else[/COLOR]
        oStr = oStr & ";" & Dn.Offset(, 6) & " " & Dn.Offset(, 12)
    [COLOR="Navy"]End[/COLOR] If
        Temp = Dn
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[pjmsimmons]

Thanks Mick. That's just about there!

regards

Paul