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.

 

[chrisscotty]

Nope..subscript out of range

 

[Legacy 68668]

Then I can not help you more, unless you find the line that raise the error. Sorry.

 

[chrisscotty]

I understand.

You have put alot of effort and I appreciate.

A couple thoughts.

Could it be because some of the entries are Canadian ?.

Really should not make a difference as the format is the same


Zia Montgomery

Chapters: Scarborough

Company: ABC INC
3100 Lowell
Montreal, QC D4R 1X6, CANADA
Bus. Telephone: (416) 337-7721
Fax: (416) 333-5555
E-mail: ziam@abcinc.ca
NEXT ENTRY

Lastly, The code below worked like a dream..from when we started the second time when I asked if we could separate the line with name address city postal code province country.

The only difference is I just need the name and address separate (and they are on separate lines just like the ones with headers (example below). The city province state can stay on the same line. Is it a problem because the name and address city,state zip have no header?

This code was so clean =-)

If you can not help anymore ..no worries..

Thanks

[-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
End Function
[-/code]

 

[Legacy 68668]

No, it shouldn't be a problem as long as the data is how you described.

Just try
add one line

On Error Resume Next
With CreateObject("Scripting.Dictionary")

and see the result.

 

[chrisscotty]

K now we are getting somewhere !


Worked almost perfectly .

It separated zip and city and country and other headers but did not include any names just the term "NEXT ENTRY" in every single cell in A on its ...

It also did not enter the street address either.

On a side note, it also inserted N/A from K to S all the way down in every cell


Here is the code I used:

[-code]
Sub test()
Dim fn As String, temp As String, n As Long, t As Long, flg As Boolean, a(), x, y
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 10)
n = 1
On Error Resume Next
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 InStr(e, ",") = 0 Then
If Not .exists("Address") Then
t = t + 1: a(1, t) = "Address"
.Add "Address", t
End If
a(n, .Item("Address")) = e
Else
y = 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
a(n, .Item("State")) = y(0)
If UBound > 0 Then a(n, .Item("Zip")) = y(1)
If UBound > 1 Then a(n, .Item("Country")) = y(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
[-/code]

 

[chrisscotty]

The odd name also has a desgination but that should not make a difference,should it ?... as it is on the same line.

Such as:

Zia K. Montgomery ACKM

or

Mr. Zia K. Montgomery ACKM

 

[Legacy 68668]

Doesn't matter unless the name contains ";" or ",".
try

Sub test()
Dim fn As String, temp As String, n As Long
Dim t As Long, flg As Boolean, a(), x, y
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 10)
n = 1 : a(n, 1) = "Name"
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each e In Split(temp, vbCrLf)
        If Trim(e) <> "" Then
            If n > 1 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 InStr(e, ",") < 1 Then
                            a(n, .Item("Address")) = e
                        Else
                            y = 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
                            a(n, .item("State")) = y(0)
                            If UBound(y) > 0 Then a(n, .item("Zip")) = y(1) 
                            If UBound(y) > 1 Then a(n, .item("Country")) = y(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

Code tag : [|code] code [|/code] (no sapce)
Not [-code] code [-/code], I said w/o -

 

[chrisscotty]

subscript out of range when I pasted directly from the code you sent .

I looked through it and noticed that it did not include


"On Error Resume Next" so pasted that again above

With CreateObject("Scripting.Dictionary")


and it was close again accept it went A to I and there were no names and no street address and in column A there was the chapters: header

 

[Legacy 68668]

It was showing correctly before, besizes the Sate, Zip, Country, right ?

 

[chrisscotty]

It was showing fine except for NEXT ENTRY was entered in all the A column cells and the name was not showing anywhere nor was the street address.