Please Help..Code to Rearrange Data..

[malcom]

Please help me rearrange a single column (A) of data to four columns (B,C,D,E)
Column B will have Primary Category
Column C will have Establishment Names
Column D will have Addresses
Column E will have Telephone Numbers

each set of data in column A is separated by at least one blank row.

each data set begins with establishment name (ALL CAPS)
establishment name (ALL CAPS) may be 1 or 2 rows.
if it contains two rows of establishment name:
if ESTNAME1 is exactly found in ESTNAME2, only ESTNAME2 is used.
if ESTNAME2 is exactly found in ESTNAME1, only ESTNAME1 is used.
else, they will be concatenated. "ESTNAME1 ESTNAME2"

address(NOT all caps) is next to the establishment name and may also be 1 or 2 rows.
if it contains two rows of address, they will be concatenated. "ADDRESS1, ADDRESS2"

next to address is telephone number. always 1 line
telephone number will always contain at least 6 numbers on its right.

next to telephone number is the primary category
"Primary category: " always appears on primary category and only the words next to it is needed. Say, "Hotel & Restaurant" only for "Primary category: Hotel & Restaurant"

sometimes, an extra line follows after primary category. This always begins with "Inquire". This is useless.

the output will be four column of data with number of rows equal to the number of data sets on column A.
as long as the four column data is already correct, column A may be removed for its not needed anymore.

Data in column A looks like:

ACE PHILX HOTEL CORPORATION
Mando Pavilion Hotel United Nations
1000 Mando
522291121
Primary Category: Hotels
Inquire by email ·

AMORA TERRA HOTEL
Iznart Moxo City, Moxo
036568989
Primary Category: Hotels

HOTELLACAVANA
BEST WESTERN HOTEL LA CAVANA
G/F Hotel La Cavana 1234 Marc Pila Street
5000 Monague
5242631
Primary Category: Hotels
Inquire by email · Inquire by fax ·

BETELON GUEST HOUSE
Betelon Guest House Rova Madano
6450 Magabeck, Ore Nempho
(045)6690000
Primary Category: Hotels
Inquire by email ·

BINDO SUITES
BINDO SUITES
Pong Street Corner Pla Street Bindo 4000 Mora
5686894
Primary Category: Hotels
Inquire by email · Inquire by fax · Visit web site ·

CARPIT TOURIST
CARPIT TOURIST INN INC
Pres Meva Blvd Goto City, Bamu
(046)2656969
Primary Category: Hotels

------------------------
Column B: Primary Categories will be:
Hotels
Hotels
Hotels
Hotels
Hotels
Hotels

Column C; establishment names will be:
ACE PHILX HOTEL CORPORATION
AMORA TERRA HOTEL
HOTELLACAVANA BEST WESTERN HOTEL LA CAVANA
BETELON GUEST HOUSE
BINDO SUITES
CARPIT TOURIST INN INC

Column D: addresses will be:
Mando Pavilion Hotel United Nations, 1000 Mando
Iznart Moxo City, Moxo
G/F Hotel La Cavana 1234 Marc Pila Street, 5000 Monague
Betelon Guest House Rova Madano 6450, Magabeck, Ore Nempho
Pong Street Corner Pla Street Bindo 4000 Mora
Pres Meva Blvd Goto City, Bamu

Column E numbers will be:
522291121
036568989
5242631
(045)6690000
5686894
(046)2656969


thank you very much!!!

 

[agihcam]

Hi malcom -

try this code;

Sub test()
Dim i As Long
On Error Resume Next
Application.ScreenUpdating = False
Columns("b:e").ClearContents
[b1].Resize(, 4) = Array("Primary Category", "Establishment Names", "Addresses", "Tel No")
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
'single establishment name
If UCase(Cells(i, "a").Value) = Cells(i, "a").Value _
And UCase(Cells(i + 1, "a").Value) <> Cells(i + 1, "a").Value _
And Cells(i, "a") <> "" _
And UCase(Cells(i - 1, "a").Value) = "" Then
Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i, "a").Value
'double establishment name not equal
ElseIf UCase(Cells(i, "a").Value) = Cells(i, "a").Value _
And UCase(Cells(i + 1, "a").Value) = Cells(i + 1, "a").Value _
And Cells(i, "a") <> "" _
And UCase(Cells(i - 1, "a").Value) = "" _
And UCase(Cells(i, "a").Value) <> Cells(i + 1, "a").Value Then
    If Cells(i + 1, "a") Like Cells(i, "a") & "*" Then
        Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i + 1, "a")
        ElseIf Cells(i, "a") Like Cells(i + 1, "a") & "*" Then
        Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i, "a")
        Else
        Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i, "a").Value & " " & Cells(i + 1, "a").Value
        End If
'double establishment name, equal names
ElseIf UCase(Cells(i, "a").Value) = Cells(i + 1, "a").Value _
And UCase(Cells(i + 1, "a").Value) = Cells(i + 1, "a").Value _
And Cells(i, "a") <> "" _
And UCase(Cells(i - 1, "a").Value) = "" Then
Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i, "a").Value
End If

'extract primary category
If Cells(i, "a").Value Like "Primary Category*" Then
Range("b" & Rows.Count).End(xlUp).Offset(1) = Mid(Cells(i, "a").Value, 18, Len(Cells(i, "a").Value) - 17)
End If
If Cells(i, "a").Value Like "Primary Category*" Then
Columns("e").NumberFormat = "@"
Range("e" & Rows.Count).End(xlUp).Offset(1) = Cells(i - 1, "a").Value
End If
'extract addresses
If Cells(i, "a").Value Like "Primary Category*" Then
If UCase(Cells(i - 3, "a").Value) <> Cells(i - 3, "a") Then
Range("d" & Rows.Count).End(xlUp).Offset(1) = Cells(i - 3, "a").Value & " " & Cells(i - 2, "a").Value
Else
Range("d" & Rows.Count).End(xlUp).Offset(1) = Cells(i - 2, "a").Value
End If
End If
Next
Columns("a").Delete
Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

 

[acw]

Hi

Another way. Data is in column A and starts from row 2

Sub ccc()
  'clear out any existing data
  Range("B:E").ClearContents

  For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
    
    If Not IsEmpty(Cells(i, 1)) Then
      If Left(Cells(i, 1), 17) = "Primary Category:" Then
        outrow = i
        Cells(outrow, 2).Value = WorksheetFunction.Substitute(Cells(i, 1).Value, "Primary Category: ", "")
        Cells(outrow, 5).Value = Cells(i - 1, 1).Value
        i = i - 2
        If checkcase(Cells(i, 1)) And checkcase(Cells(i - 1, 1)) And checkcase(Cells(i - 2, 1)) Then
          '3 lines of address
          Cells(outrow, 4).Value = Cells(i - 2, 1).Value & ", " & Cells(i - 1, 1).Value & ", " & Cells(i, 1).Value
          i = i - 3
        ElseIf checkcase(Cells(i, 1)) And checkcase(Cells(i - 1, 1)) Then
          '2 lines of address
          Cells(outrow, 4).Value = Cells(i - 1, 1).Value & ", " & Cells(i, 1).Value
          i = i - 2
        Else
          '1 line of address
          Cells(outrow, 4).Value = Cells(i, 1).Value
          i = i - 1
        End If
        
        If Not checkcase(Cells(i, 1).Value) And IsEmpty(Cells(i - 1, 1)) Then
          'one line of name
          Cells(outrow, 3).Value = Cells(i, 1).Value
          i = i - 1
        'End If
        '2 lines of name
        ElseIf Cells(i, 1).Value = Cells(i - 1, 1).Value Then
        'name is the same
          Cells(outrow, 3).Value = Cells(i, 1).Value
          i = i - 2
        ElseIf InStr(1, Cells(i, 1).Value, Cells(i - 1, 1).Value) > 0 Then
        'name1 is in name2
          Cells(outrow, 3).Value = Cells(i, 1).Value
          i = i - 2
        ElseIf InStr(1, Cells(i - 1, 1).Value, Cells(i, 1).Value) > 0 Then
        'name2 is in name1
          Cells(outrow, 3).Value = Cells(i - 1, 1).Value
          i = i - 2
        Else
        'names are different
          Cells(outrow, 3).Value = Cells(i - 1, 1).Value & Cells(i, 1).Value
          i = i - 2
        End If
     End If
    End If
  Next i
End Sub
Function checkcase(st As String)
'determines if the string is all capiatals
  Dim regex As Object
  Set regex = CreateObject("vbscript.regexp")
  With regex
    .Pattern = "[^A-Z ]"
    .Global = True
    checkcase = .test(st)
  End With
End Function

Tony

 

[malcom]

Thank you very much

Thank you very much.. I'll try this later when i reach home...

 

[malcom]

Thank u very much @agihcam and @acw!

@agihcam, ur code works perfect..
@acw, ur code works but with some comments, pm'd u..

id like to add something.. pls consider..

after seeing the result, i think i need to add one more column, say column F.
column F will contain location.. but not as specific as the address..

column F will be an additional. not affecting the column alotted for address.

column F will come out something like this..
Mando
Moxo
Monague
Ore Nempho
Mora
Bamu

this may be of 1 word, words or phrase with ",".....
the basis for this will be from a specific list. please suggest where i shall place this list (code, separate column, separate sheet, or where else)
the list may contain something like this
LIST:
Barera, Bamu
Baxo, Barera
Coro
Derama
Mando
Monague
Moxo
Ore Nempho
Bamu

the searching will always start from top of the list. once a word/phrase is found in the adrress, it will be used.

e.g.: if the address had only been XXXXXX Barera, Bamu
"Barera, Bamu" will have been used. but since the phrase isnt used, searching had continued till it found "Bamu" and "Bamu" will be used.
The reason for this is that i will provide a very long list from very specific down to general..

"Mora" for example is not found in the list. if ever none in the list is found in the address, the last word in the address is used..

Thank you very much!

--------------------------------------------------------------------------

@agihcam

i think you missed this..

Quote:

if ESTNAME1 is exactly found in ESTNAME2, only ESTNAME2 is used.
if ESTNAME2 is exactly found in ESTNAME1, only ESTNAME1 is used.
else, they will be concatenated. "ESTNAME1 ESTNAME2"


i think you considered only 2 out of 3...

thank you very much!
i appreciate it..

============================================

ive got a problem.. not all data set have telephone number..
in this case, the address or part of the address is found on the telephone number column after running the code..

 

[agihcam]

@agihcam

i think you missed this..

Quote:

if ESTNAME1 is exactly found in ESTNAME2, only ESTNAME2 is used.
if ESTNAME2 is exactly found in ESTNAME1, only ESTNAME1 is used.
else, they will be concatenated. "ESTNAME1 ESTNAME2"


i think you considered only 2 out of 3...

thank you very much!
i appreciate it..

I have revised the code, please try again.

ive got a problem.. not all data set have telephone number..
in this case, the address or part of the address is found on the telephone number column after running the code..

it's not our fault. that's the importance of providing accurate data layout for you to obtain a best and suitable result. in this case you need to provide accurate data sample including all the possible variations from your data.

 

[malcom]

i revised @agihcam's code.. works great now even without telephone number...

Sub test()
Dim i As Long
On Error Resume Next
Application.ScreenUpdating = False
Columns("b:e").ClearContents
[b1].Resize(, 4) = Array("Primary Category", "Establishment Names", "Addresses", "Tel No")
For i = 1 To Range("a" & Rows.Count).End(xlUp).Row
    'single establishment name
    If UCase(Cells(i, "a").Value) = Cells(i, "a").Value _
    And UCase(Cells(i + 1, "a").Value) <> Cells(i + 1, "a").Value _
    And Cells(i, "a") <> "" And Cells(i, "a") <> " " _
    And UCase(Cells(i - 1, "a").Value) = "" Then
        Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i, "a").Value
    'double establishment name not equal
    ElseIf UCase(Cells(i, "a").Value) = Cells(i, "a").Value _
    And UCase(Cells(i + 1, "a").Value) = Cells(i + 1, "a").Value _
    And Cells(i, "a") <> "" And Cells(i, "a") <> " " _
    And UCase(Cells(i - 1, "a").Value) = "" _
    And UCase(Cells(i, "a").Value) <> Cells(i + 1, "a").Value Then
        If Cells(i + 1, "a") Like Cells(i, "a") & "*" Then
            Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i + 1, "a")
        ElseIf Cells(i, "a") Like Cells(i + 1, "a") & "*" Then
            Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i, "a")
        Else
            Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i, "a").Value & " " & Cells(i + 1, "a").Value
        End If
    'double establishment name, equal names
    ElseIf UCase(Cells(i, "a").Value) = Cells(i + 1, "a").Value _
    And UCase(Cells(i + 1, "a").Value) = Cells(i + 1, "a").Value _
    And Cells(i, "a") <> "" And Cells(i, "a") <> " " _
    And UCase(Cells(i - 1, "a").Value) = "" Then
        Range("c" & Rows.Count).End(xlUp).Offset(1) = Cells(i, "a").Value
    End If
    
    'extract primary category
    If Cells(i, "a").Value Like "Primary Category*" Then
        Range("b" & Rows.Count).End(xlUp).Offset(1) = Mid(Cells(i, "a").Value, 18, Len(Cells(i, "a").Value) - 17)
        'extract telephone number
        Columns("e").NumberFormat = "@"
        If Asc(Right(Cells(i - 1, "a"), 1)) < 58 _
        And Asc(Right(Cells(i - 1, "a"), 1)) > 47 Then
            Range("e" & Rows.Count).End(xlUp).Offset(1) = Cells(i - 1, "a").Value
        Else
            Range("e" & Rows.Count).End(xlUp).Offset(1) = " "
        End If
        'extract addresses
        If UCase(Cells(i - 3, "a").Value) <> Cells(i - 3, "a") Then
            Range("d" & Rows.Count).End(xlUp).Offset(1) = Cells(i - 3, "a").Value & ", " & Cells(i - 2, "a").Value
        Else
            Range("d" & Rows.Count).End(xlUp).Offset(1) = Cells(i - 2, "a").Value
        End If
    End If
Next
Columns("a").Delete
Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

i wrote this second code to add the additional column.. where i temporarily placed my long list on column f..

Sub Attempt()
Columns("e").ClearContents
Application.ScreenUpdating = False
For f = 1 To Range("f65536").End(xlUp).Row
    For c = 2 To Range("c65536").End(xlUp).Row
        If UCase(Cells(c, "c").Value) Like "*" & UCase(Cells(f, "f").Value) _
        And Cells(c, "e").Value = "" Then
            Cells(c, "e").Value = Cells(f, "f").Value
        End If
    Next c
Next f
Application.ScreenUpdating = True
End Sub

is there other way in doing this? coz later, i would be dealing with maybe hundreds of sheets.. and i dont wana copy the list in evry sheet after i run the first code.. s there a way to include the list in the code instead?
maybe ill just place the list in a separate sheet so i can work smoothly..
please advise..tanx..

 

[agihcam]

Good to hear that you can easily debug the codes to suit your needs. I would suggest to list down the Locations on a separate sheet instead on in column F.

Also, your code (Attempt) will not display the result when the Location did not found on the list if I'm not mistaken.

 

[malcom]

thanx @agihcam...
uhmm.. il try to transfer my list to separate sheet..
i observed that its better to leave it this way.. so those not found in my list will be left blank and this means i hav to add up my list to complete all possiblities..