rearranging rows to columns

[vilas desai]

Dear experts,

I have copied in excel 7 worksheets information as below:

The attachment shows how the information is copied in the Worksheet "current file"
and the way I would like to see it in the worksheet 'file format"

Can you please help me on this?
The code is for the workbook and not just the worksheet

Thanks in advance and best regards
Vilas Desai

[Rudi]

Do the two examples represent the only variations of the contact info or are there other variations with additional fields or addresses that occupy three rows instead of just over two? Also are the names always separated from the title with a hyphen?

[vilas desai]

Yes, I forgot the mention that the names are followed by a hyphen. ( i would believe that may be the only way to have dilimiting done. Addresses can occupy three rows also. But the number of fields is 6 with Fax When the address is of two lines, I have observed from about 8 to 8 examples that the location is mentioned on the thirds line. lease see the attached file with some more data.

[Rudi]

Your attachment contains the same info as your original attachment. Did you send the correct data?

[vilas desai]

Sorry about that. I did not save the downloaded file back to the desk top file. Any way here it is again sent....

[Rudi]

This code works for the 5 address samples you sent. However, the splitting off of the address depends on if the area code starts with 9. If the code starts with any other number, it will not split.

Code: Select all

Sub MakeList()
Dim shSrc As Worksheet
Dim shDest As Worksheet
Dim rgSrc As Range
Dim rC As Range
Dim iCnt As Integer

Const shName = "current copy" '< Modify this name to the sheet name holding the address details

    Set shSrc = Worksheets(shName)
    Set rgSrc = shSrc.UsedRange.Columns(1)
    Set shDest = Worksheets.Add(After:=shSrc)
    Application.ScreenUpdating = False
    For Each rC In rgSrc.Cells
        On Error Resume Next
        rC.Value = Split(rC.Value, ":")(0)
        On Error GoTo 0
        If rC.Value = "Name" Then
            iCnt = shDest.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
            shDest.Cells(iCnt, 1).Value = Trim(Split(rC.Offset(0, 1).Value, "-")(0))
        End If
        If rC.Value = "Address" Then shDest.Cells(iCnt, 2).Value = Trim(Split(rC.Offset(2, 1).Value, "9")(0))
        If rC.Value = "Phone" Then shDest.Cells(iCnt, 3).Value = rC.Offset(0, 1).Value
        If rC.Value = "Email" Then
            shDest.Cells(iCnt, 4).Value = rC.Offset(0, 1).Value
            ActiveSheet.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 4), Address:="mailto:" & rC.Offset(0, 1).Formula
        End If
        If rC.Value = "Website" Then
            shDest.Cells(iCnt, 5).Value = rC.Offset(0, 1).Value
            ActiveSheet.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 5), Address:=rC.Offset(0, 1).Formula
        End If
    Next rC
    shDest.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

[vilas desai]

Thanks Rudi. It works perfect, but in this case all codes started with 9 because it was Ca. If the state changes to some thing that begins with say 7 for example, pease let me know what changes I would have to make. Thanks again.

[HansV]

Change

shDest.Cells(iCnt, 2).Value = Trim(Split(rC.Offset(2, 1).Value, "9")(0))

to

shDest.Cells(iCnt, 2).Value = Left(rC.Offset(2, 1).Value, InStr(rC.Offset(2, 1).Value, ",") + 3)

[vilas desai]

Thanks Hans. Please advise me that particular element in this code which will allow me to change 9 to any other number. What adds to the offset to make it say for example 7. Please provide a couple of example

[HansV]

rC.Offset(2, 1) is the cell containing "city, state zip country".

InStr(rC.Offset(2, 1).Value, ",") finds the position of the comma in the value of this cell. We add 3 to this position to include the space and state abbreviation after the comma.
Left(rC.Offset(2, 1).Value, InStr(rC.Offset(2, 1).Value, ",") + 3) returns the text up to the comma plus the space and state abbreviation.

So this version does not depend on the first digit of the zip code at all, it will work for all zip codes.

[vilas desai]

The modified code removes the Address col completely

Please see the modified code. I guess i would have made some mistake.

Code: Select all

Sub MakeList()
Dim shSrc As Worksheet
Dim shDest As Worksheet
Dim rgSrc As Range
Dim rC As Range
Dim iCnt As Integer

Const shName = "current copy" '< Modify this name to the sheet name holding the address details

    Set shSrc = Worksheets(shName)
    Set rgSrc = shSrc.UsedRange.Columns(1)
    Set shDest = Worksheets.Add(After:=shSrc)
    Application.ScreenUpdating = False
    For Each rC In rgSrc.Cells
        On Error Resume Next
        rC.Value = Split(rC.Value, ":")(0)
        On Error GoTo 0
        If rC.Value = "Name" Then
            iCnt = shDest.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
            shDest.Cells(iCnt, 1).Value = Trim(Split(rC.Offset(0, 1).Value, "-")(0))
        End If
        If rC.Value = "Address" Then [b][u]shDest.Cells(iCnt, 2).Value = Left(rC.Offset(2, 1).Value, InStr(rC.Offset(2, 1).Value, ",") + 3)[/u][/b]
        If rC.Value = "Phone" Then shDest.Cells(iCnt, 3).Value = rC.Offset(0, 1).Value
        If rC.Value = "Email" Then
            shDest.Cells(iCnt, 4).Value = rC.Offset(0, 1).Value
            ActiveSheet.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 4), Address:="mailto:" & rC.Offset(0, 1).Formula
        End If
        If rC.Value = "Website" Then
            shDest.Cells(iCnt, 5).Value = rC.Offset(0, 1).Value
            ActiveSheet.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 5), Address:=rC.Offset(0, 1).Formula
        End If
    Next rC
    shDest.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

[HansV]

In the workbook that you posted higher up in this thread, the "file format" tab doesn't have an Address column. So Rudi's code ignores the Address information...

[vilas desai]

Ah, got it. so please advise if I need to send a new work book that includes the address col Actually te reason to do that was a compromise because it was apparently difficult.

[HansV]

Here is a version that handles the address too.

Code: Select all

Sub MakeList()
    Dim shSrc As Worksheet
    Dim shDest As Worksheet
    Dim rgSrc As Range
    Dim rC As Range
    Dim iCnt As Integer

    Const shName = "current copy" '< Modify this name to the sheet name holding the address details

    Set shSrc = Worksheets(shName)
    Set rgSrc = shSrc.UsedRange.Columns(1)
    Set shDest = Worksheets.Add(After:=shSrc)
    Application.ScreenUpdating = False
    For Each rC In rgSrc.Cells
        On Error Resume Next
        rC.Value = Split(rC.Value, ":")(0)
        On Error GoTo 0
        Select Case rC.Value
        Case "Name"
            iCnt = shDest.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
            shDest.Cells(iCnt, 1).Value = Trim(Split(rC.Offset(0, 1).Value, "-")(0))
        Case "Address"
            shDest.Cells(iCnt, 2).Value = rC.Offset(0, 1).Value
            shDest.Cells(iCnt, 3).Value = Left(rC.Offset(2, 1).Value, InStr(rC.Offset(2, 1).Value, ",") + 3)
        Case "Phone"
            shDest.Cells(iCnt, 4).Value = rC.Offset(0, 1).Value
        Case "Email"
            shDest.Cells(iCnt, 5).Value = rC.Offset(0, 1).Value
            shDest.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 4), Address:="mailto:" & rC.Offset(0, 1).Formula
        Case "Website"
            shDest.Cells(iCnt, 6).Value = rC.Offset(0, 1).Value
            shDest.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 5), Address:=rC.Offset(0, 1).Formula
        End Select
    Next rC
    shDest.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

[vilas desai]

Dear Hans,
Thanks. The address gets truncated the last part...

Address 265 Admiral Trost Drive

Columbia, IL 62236 United States

the code gives this result

265 Admiral Trost Drive

For me the second or third line of the address which contains the Town name and Zip is more important .... Columbia, IL 62236

Can we achieve this? If not the can we have all the three lines of the address mentioned in one column

Thanks and best regards

Vilas Desai

[Rudi]

    
Hans's code seems to be working OK, unless I have missed a point?

SC1.jpg

BTW: In the code Hans posted you just need to update the hyperlink references:

Change this line:

Code: Select all

shDest.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 4), Address:="mailto:" & rC.Offset(0, 1).Formula

to become:

Code: Select all

shDest.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 5), Address:="mailto:" & rC.Offset(0, 1).Formula

And change this line:

Code: Select all

shDest.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 5), Address:=rC.Offset(0, 1).Formula

to become:

Code: Select all

shDest.Hyperlinks.Add Anchor:=shDest.Cells(iCnt, 6), Address:=rC.Offset(0, 1).Formula

[vilas desai]

Perfect, and apologies Hans and Rudi. I made some mistake and corrected it when i visited the workbook again. I will now see Rudi's option to retain the hyperlinks. Thanks to both of you.