PDA

View Full Version : [SOLVED] Do Loop and Merge Texts



snoopies
08-07-2005, 10:24 PM
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
08-07-2005, 11:03 PM
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
08-08-2005, 03:14 AM
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
08-08-2005, 04:21 AM
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
08-08-2005, 09:22 AM
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?:doh:

Bob Phillips
08-08-2005, 09:30 AM
How do we know they aren't supposed to merge?

jindon
08-08-2005, 09:33 AM
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
08-08-2005, 09:38 AM
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
08-08-2005, 09:44 AM
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
08-08-2005, 09:45 AM
Code has been edited

do you want to try again?

jindon
08-08-2005, 09:52 AM
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
08-08-2005, 09:53 AM
Yes, i did..

That's the result with your latest code :)

snoopies
08-08-2005, 10:05 AM
Just tried the code posted in 12:52 AM, same result? :doh:
Thx indeed.

jindon
08-09-2005, 01:26 AM
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
08-09-2005, 07:32 AM
So Great!
It works, Thanks a lot! :)