Do Loop and Merge Texts

[snoopies]

Hi all,

I have 5000 rows of raw data in the format like this (in column A) :

Bangkok
Bank Visa
(2071)
Krungsri
Visa
(2081)
Krung
ThaiVisa
(2091)
..................


How can I loop these rows and merge the texts in a format like:

BangKok Bank Visa (2071)
Krungsri Visa (2081)
Krung Thai Visa (2091)

(xxxx) is actually the seperator of different text names,

Please kindly advise...thanks!

[Jacob Hilderbrand]

Try this:

Option Explicit

Sub MergeData()
Dim i               As Long
Dim LastRow         As Long
Dim StartRow        As Long
Dim DelRange        As Range
StartRow = 1
    LastRow = Range("A65536").End(xlUp).Row
    Set DelRange = Range("A" & StartRow + 1)
    For i = 1 To LastRow Step 3
        Range("A" & i).Value = Trim(Range("A" & i).Text) & " " & _
            Trim(Range("A" & i + 1).Text) & " " & Trim(Range("A" & i + 2).Text)
        Set DelRange = Union(DelRange, Range("A" & i + 1), Range("A" & i + 2))
    Next i
    DelRange.EntireRow.Delete
Set DelRange = Nothing
End Sub

[Bob Phillips]

If the rows are variable with (xxxx) signifying the end, try

Sub MergeData()
Dim i As Long, j As Long
Dim iLastRow As Long
Dim iStartRow As Long
Dim rngDel As Range
Dim stemp As String
iStartRow = 1
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set rngDel = Range("A" & iStartRow + 1)
    For i = 1 To iLastRow
        stemp = Cells(i, "A").Text
        j = i + 1
        Do
            stemp = stemp & " " & Trim(Range("A" & j).Text)
            Set rngDel = Union(rngDel, Range("A" & j))
            j = j + 1
        Loop Until Left(Cells(j - 1, "A").Value, 1) = "("
        Range("A" & i).Value = stemp
        i = j - 1
    Next i
    rngDel.EntireRow.Delete
Set rngDel = Nothing
End Sub

[jindon]

Hi

This should be fast

Sub test()
Dim a, i As Long, ii As Integer, iii As Integer, result()
a = Range("a1", Range("a65536").End(xlUp)).Value
Range("a:a").ClearContents
For i = LBound(a) To UBound(a)
    If InStr(a(i, 1), "(") = 0 Then
        ii = ii + 1: ReDim Preserve result(1 To ii): result(ii) = a(i, 1)
        Do
            iii = iii + 1
            result(ii) = result(ii) & Chr(32) & a(i + iii, 1)
        Loop Until InStr(a(i + iii, 1), "(") > 0 Or i + iii >= UBound(a)
    End If
    i = i + iii: iii = 0
Next
Range("a1").Resize(UBound(result)) = Application.Transpose(result)
End Sub

[snoopies]

Thanks for help, thank you so much !

DRJ, xld is right, the rows are variable with (xxxx)
But I have some rows which don't need to merge..(e,g row 1&2 below)

Nokia (2)
Samsung (1)
Motorola
(4)
Sony
Ericsson
(3)


With xld's code, the result is :
Nokia (2) Samsung (1) Motorola (4)<- 1st row
Sony Ericsson (3) <- 2nd row


With Jindon's code, the result is:
Motorola (4) <-1st row
Sony Ericsson (3) <- 2nd row

Nokia (2) Samsung (1)<-- being cut?

[Bob Phillips]

How do we know they aren't supposed to merge?

[jindon]

Then try this

Sub test()
    Dim a, i As Long, ii As Integer, iii As Integer, result()
    a = Range("a1", Range("a65536").End(xlUp)).Value
    Range("a:a").ClearContents
    For i = LBound(a) To UBound(a)
        If InStr(a(i, 1), "(") <> 1 Then
            ii = ii + 1: ReDim Preserve result(1 To ii): result(ii) = a(i, 1)
            Do
                iii = iii + 1
                result(ii) = result(ii) & Chr(32) & a(i + iii, 1)
            Loop Until InStr(a(i + iii, 1), "(") = 1 Or i + iii >= UBound(a)
        End If
        i = i + iii: iii = 0
    Next
    Range("a1").Resize(UBound(result)) = Application.Transpose(result)
End Sub

code has been edited:

[snoopies]

Hello,

That's a problem...actually the raw data is imported from a word file which is given by third parties.. I don't know which rows don't need to merge,too

On the other way, how can I divide /will it difficult to divide
Nokia (2) Samsung (1) Motorola (4) into 3 different rows ?

[snoopies]

Hi Jindon,

Thx for help

With your new code, the result will be same as xld's..
Nokia (2) Samsung (1) Motorola (4)<- 1st row
Sony Ericsson (3) <- 2nd row

[jindon]

Code has been edited

do you want to try again?

[jindon]

Ah ha,
I see what you want

Sub test()
	Dim a, i As Long, ii As Integer, iii As Integer, result()
	a = Range("a1", Range("a65536").End(xlUp)).Value
	Range("a:a").ClearContents
	For i = LBound(a) To UBound(a)
		If InStr(a(i, 1), "(") = 0 Then
			ii = ii + 1: ReDim Preserve result(1 To ii): result(ii) = a(i, 1)
			Do
				iii = iii + 1
				result(ii) = result(ii) & Chr(32) & a(i + iii, 1)
			Loop Until InStr(a(i + iii, 1), "(") = 1 Or i + iii >= UBound(a)
		i = i + iii: iii = 0
		ElseIf InStr(a(i, 1), "(") > 1 Then
			ii = ii + 1: ReDim Preserve result(1 To ii): result(ii) = a(i, 1)
		End If
	Next
	Range("a1").Resize(UBound(result)) = Application.Transpose(result)
End Sub

[snoopies]

Yes, i did..

That's the result with your latest code

[snoopies]

Just tried the code posted in 12:52 AM, same result?
Thx indeed.

[jindon]

soopies,
final code

Sub test()
    Dim a, i As Long, ii As Integer, iii As Integer, result(), x
    Columns(1).Replace what:=Chr(27), replacement:=vbNullString
    a = Range("a1", Range("a65536").End(xlUp)).Value
    Range("a:a").ClearContents
    For i = LBound(a) To UBound(a)
        If Len(Trim(a(i, 1))) > 0 Then
            x = Trim(a(i, 1))
            If InStr(1, x, ")") <> Len(x) Then
                ii = ii + 1: ReDim Preserve result(1 To ii): result(ii) = x
                Do
                    iii = iii + 1: x = Trim(a(iii + i, 1))
                    result(ii) = result(ii) & Chr(32) & x
                Loop Until InStr(1, x, ")") = Len(x) Or i + iii >= UBound(a)
                    i = i + iii: iii = 0
            Else
                ii = ii + 1: ReDim Preserve result(1 To ii): result(ii) = x
            End If
        End If
    Next
    Range("a1").Resize(UBound(result)) = Application.Transpose(result)
End Sub

[snoopies]

So Great!
It works, Thanks a lot!