Transpose Function..Empty Cells and Characters

[chrisscotty]

Hello All,

I just recently switched to Excel 2007 and am not that familiar with the program.

I have a question that has 3 components.


I have alot of data in Column A that has many blank cells.

I performed several searches and have still not been able to remove them.

This particular method worked if I was selecting a small amount of data

http://www.tech-recipes.com/rx/2189/excel_2007_eliminate_blank_rows/

Yet when I use with the entire list I get the error "selection is too large".


What I basically want to do is take the data that I have gathered and transpose it so I can save as a csv file and import in to my contact manager.


The data looks like this:
NEXT ENTRY
" "




Mr. Rene Reynolds

Chapters: Philadelphia
Position/Title: Machinist
Company: ABC Limited

71 Maybrook Drive
Philadelphia, PA 19118, USA
Bus. Telephone: (215) 298-8108x265
Fax: (215) 298-3545
E-mail: rene.reynolds@abc.com
NEXT ENTRY
" "






Ms Carol Jones

Chapters: Ottawa
Position/Title: Benefits Administrator

28 Reeds Road
North Bay, ON K9J 0K4, CANADA
E-mail: c_jones@yahoo.com
NEXT ENTRY


Mr Billl Jones

Chapters: Binghampton
NEXT ENTRY

----------

So each name after "Next ENTRY" is a new entry and I want the data transposed

Now, all this is consistent as far as the order..name, chapter, postion etc.

The thing is not all names have all the information some just have the name and phone, name and chapter etc etc.

Mr. Rene Reynolds

Chapters: Philadelphia
Position/Title: Machinist
Company: ABC Limited

71 Maybrook Drive
Philadelphia, PA 19118, USA
Bus. Telephone: (215) 298-8108x265
Fax: (215) 298-3545
E-mail: rene.reynolds@abc.com

So..first I want to get rid of all the empty cells and move up and then transpose the data and have it correspond to each entry and if it missing a fied it just skips over.

Oh and one more thing =-)

There appears a little question mark that I can not delete. Some of them appear before the name and some of them appear under NEXT ENTRY and appear as " " when I paste data from excel in to a txt file.

Any help would be greatly appreciated.

 

[Legacy 68668]

chrisscotty

Can you show me the result again for me ?
Your explanations are confusing me

 

[chrisscotty]

The Code below that I received is working perfectly in that it transposes all the data that has headers such as Chapters: Position/Title: Company :Bus.Telephone: Fax: E-Mail:

The only problem is that it puts the name the street address and city state and country all on the same line so I can not separate each field. (see example below) which is required for me to import in to my contact manager as a csv or tab delimited file. The way it is now I can not separate the name from the street.

I can have the city state and zip on the same line as it is separated by commas (and is all on the same line in the original entry)

The question is:

Can I have the name separate and the street address separate as I do for all the other fields that have a original header (the name and street address do not)

Please note that the name and address are ALWAYS on a different line in the same order. All entries have a name but not all have street address and city state etc.

(please also note there are spaces between in between name chapter etc but that each entry is separated by the term NEXT ENTRY

Looks like this

NEXT ENTRY



Mr. Rene Reynolds

Chapters: Philadelphia
Position/Title: Machinist
Company: ABC Limited

71 Maybrook Drive
Philadelphia, PA 19118, USA
Bus. Telephone: (215) 298-8108x265
Fax: (215) 298-3545
E-mail: rene.reynolds@abc.com
NEXT ENTRY




Bill Smith

Chapters: New York
E-mail billsmith@gmail. com


Here is the code:
Sub test()
Dim fn As String, temp As String, n As Long, t As Long, flg As Boolean, a()
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
fn = "c:\test\aaa.txt"
temp = "NEXT ENTRY" & _
CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
temp = CleanTxt(temp)
ReDim a(1 To Rows.Count, 1 To 20)
n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each e In Split(temp, vbCrLf)
If Trim(e) <> "" Then
If n > 0 Then
x = Split(e, ":")
If UBound(x) > 0 Then
If Not .exists(x(0)) Then
t = t + 1: a(1, t) = x(0): .Add x(0), t
End If
a(n, .Item(x(0))) = x(1)
Else
If flg Then
a(n, 1) = e: flg = False
Else
If Not .exists("Address") Then
t = t + 1
.Add "Address", t
End If
a(n, .Item("Address")) = a(n, .Item("Address")) & _
IIf(a(n, .Item("Address")) = "", "", " ") & e
End If
End If
End If
End If
If UCase(e) Like "*NEXT ENTRY*" Then
n = n + 1: flg = True
End If
Next
End With
ThisWorkbook.Sheets(1).Cells(1).Resize(n, t).Value = a
End Sub

Function CleanTxt(ByVal txt As String) As String
With CreateObject("VBScript.RegExp")
.Pattern = "^\s*$"
.Global = True
.MultiLine = True
CleanTxt = .Replace(txt, "")
End With


Many Thanks !!!

 

[chrisscotty]

End Function is after "End With" at the very end...

 

[Legacy 68668]

Do you want separate this part

Philadelphia, PA 19118, USA

by comma ?

State, Zip, Country ?

 

[chrisscotty]

Sure..or a separate cell if possible.

 

[chrisscotty]

Being separated the way the other data that had headers was separated is perfect.

such as Company: Phone : etc

 

[Legacy 68668]

try

Sub test()
Dim fn As String, temp As String, n As Long, t As Long, flg As Boolean, a(), x
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
fn = "c:\test\aaa.txt"
temp = "NEXT ENTRY" & _
    CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
temp = CleanTxt(temp)
ReDim a(1 To Rows.Count, 1 To 20)
n = 1
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each e In Split(temp, vbCrLf)
        If Trim(e) <> "" Then
            If n > 0 Then
                x = Split(e, ":")
                If UBound(x) > 0 Then
                    If Not .exists(x(0)) Then
                        t = t + 1: a(1, t) = x(0): .Add x(0), t
                        b(1, t) = x(0)
                    End If
                    a(n, .Item(x(0))) = x(1)
                Else
                    If flg Then
                        a(n, 1) = e: flg = False
                    Else
                        If Not e Like "*,*" Then
                            If Not .exists("Address") Then
                                t = t + 1 : b(1, t) = "Address"
                                .Add "Address", t
                                a(n, .Item("Address")) = e
                            End If
                        Else
                            x = Split(e, ",")
                            If Not .exists("State") Then
                                t = t + 1 : .add "State", t : b(1, t) = "State"
                            End If
                            If Not .exists("Zip") Then
                                t = t + 1 : .add "Zip", t : b(1, t) = "Zip"
                            End If
                            If Not .exists("Country") Then
                                t = t + 1 : .add "Country", t : b(1, t) = "Country"
                            End If
                            b(n, .item("Sate")) = x(0)
                            If UBound(x) > 0 Then b(n, .item("Zip")) = x(1) 
                            If UBound(x) > 1 Then b(n, .item("Country")) = x(2) 
                        End If
                    End If
                End If
            End If
        End If
        If UCase(e) Like "*NEXT ENTRY*" Then
            n = n + 1: flg = True
        End If
    Next
End With
ThisWorkbook.Sheets(1).Cells(1).Resize(n, t).Value = a
End Sub
 
Function CleanTxt(ByVal txt As String) As String
With CreateObject("VBScript.RegExp")
    .Pattern = "^\s*$"
    .Global = True
    .MultiLine = True
    CleanTxt = .Replace(txt, "")
End With
End Function

 

[chrisscotty]

Compile Error: Sub or Function not defined

b(1, t) = was highlighted

 

[Legacy 68668]

OOps

All b(1, t) should be a(1, t)

 

[chrisscotty]

Compile Error: Sub or Function not defined

b(n, .Item("Sate")) = was highlighted

I replaced all All b(1, t) with a(1, t) (there were 5)
-----------
Sub test()
Dim fn As String, temp As String, n As Long, t As Long, flg As Boolean, a(), x
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
fn = "c:\test\aaa.txt"
temp = "NEXT ENTRY" & _
CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
temp = CleanTxt(temp)
ReDim a(1 To Rows.Count, 1 To 20)
n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each e In Split(temp, vbCrLf)
If Trim(e) <> "" Then
If n > 0 Then
x = Split(e, ":")
If UBound(x) > 0 Then
If Not .exists(x(0)) Then
t = t + 1: a(1, t) = x(0): .Add x(0), t
a(1, t) = x(0)
End If
a(n, .Item(x(0))) = x(1)
Else
If flg Then
a(n, 1) = e: flg = False
Else
If Not e Like "*,*" Then
If Not .exists("Address") Then
t = t + 1: a(1, t) = "Address"
.Add "Address", t
a(n, .Item("Address")) = e
End If
Else
x = Split(e, ",")
If Not .exists("State") Then
t = t + 1: .Add "State", t: a(1, t) = "State"
End If
If Not .exists("Zip") Then
t = t + 1: .Add "Zip", t: a(1, t) = "Zip"
End If
If Not .exists("Country") Then
t = t + 1: .Add "Country", t: a(1, t) = "Country"
End If
b(n, .Item("Sate")) = x(0)
If UBound(x) > 0 Then b(n, .Item("Zip")) = x(1)
If UBound(x) > 1 Then b(n, .Item("Country")) = x(2)
End If
End If
End If
End If
End If
If UCase(e) Like "*NEXT ENTRY*" Then
n = n + 1: flg = True
End If
Next
End With
ThisWorkbook.Sheets(1).Cells(1).Resize(n, t).Value = a
End Sub

Function CleanTxt(ByVal txt As String) As String
With CreateObject("VBScript.RegExp")
.Pattern = "^\s*$"
.Global = True
.MultiLine = True
CleanTxt = .Replace(txt, "")
End With
End Function