UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome Guest ( Log In | Register )

 
 Reply to this topicStart new topic
> Macro to move 1 column of data to multiple columns    
 
   
dcochran
post Feb 29 2008, 11:42 AM
Post #1

UtterAccess Member
Posts: 42
I have one column which is copied and pasted as text in excel and there is several blank rows. I attached the spreadsheet example - it has 40 lenders, with the top row being the lender name (A1), followed by address(A2), city-state (A3), two blank rows(A4-A5), lender type (A6), approved date (A7), one blank row (A8), lender specialty (A9), telephone (A10) , e-mail address(A11) and two blanks rows (A12-A13) and A14 starts over again. For this example there should be 8 columns and 40 rows (lender name, address, etc...). I have started working on a macro from something similar. I couldn't figure out the best way to handle the blank rows and or remove the blanks and what to add or take out of the macro code. Thanks for your help. (I'm not very familiar with macros, so I thank you for your help.
Attached File(s)
Attached File  FHA Lender List.zip ( 12.03K ) Number of downloads: 12
 
Go to the top of the page
 
+
NateO
post Feb 29 2008, 02:06 PM
Post #2

Remembered
Posts: 5,055
From: Minneapolis, MN, USA
Hello,

What a mess. Who's giving you data in that format? And people complain about Excel, this looks like a DB programmer run amuck.

In any event, here's your hack:

CODE
Sub foobar()

Dim cl As Range, cleanRange As Range

Dim OrigCl As String, myArr() As Variant



Application.ScreenUpdating = False

On Error Resume Next

Set cleanRange = Range("A:A").SpecialCells(xlConstants, 2)

If Not Err Then

    For Each cl In cleanRange

        With WorksheetFunction

            Let cl.Value = .Clean(.Trim(cl))

        End With

    Next

    Set cleanRange = Nothing

End If



Range("A:A").SpecialCells(xlBlanks).EntireRow.Delete



Set cl = Range("A:A").Find("E-Mail Address", LookIn:=xlValues, LookAt:=xlPart)

If Not cl Is Nothing Then

    Let OrigCl = cl.Address

    cl(2).EntireRow.Insert

    Do: Set cl = Range("A:A").FindNext(cl)

        If cl.Address = OrigCl Then Exit Do

        cl(2).EntireRow.Insert

    Loop While Not cl Is Nothing

    Set cl = Nothing

End If



Let myArr = WorksheetFunction.Transpose(Range(Range("A1"), Range("A1").End(xlDown)))

Let Range("B1").Resize(, UBound(myArr)).Value = myArr

For Each cl In Intersect(Range("A2:A65536").SpecialCells(xlBlanks), _

        Range("A2:A65536").SpecialCells(xlConstants).Offset(-1))

    Let myArr = WorksheetFunction.Transpose(Range(cl(2), cl(2).End(xlDown)))

    Let Range("B65536").End(xlUp)(2).Resize(, UBound(myArr)).Value = myArr

Next



Range("A1").EntireColumn.Delete

Range("A:IV").EntireColumn.AutoFit



Application.ScreenUpdating = True

End Sub

I'd explain it, but I'm not quite sure where to start, or stop for that matter.

Merry Christmas. (IMG:http://www.utteraccess.com/forum/style_emoticons/default/wink.gif)
Go to the top of the page
 
+
dcochran
post Feb 29 2008, 02:40 PM
Post #3

UtterAccess Member
Posts: 42
Nate, That's perfect! Thank you so much... I'm getting the data from Govt website (HUD/FHA)... Again thanks so much! Have great day!

Dale
Go to the top of the page
 
+
NateO
post Feb 29 2008, 02:48 PM
Post #4

Remembered
Posts: 5,055
From: Minneapolis, MN, USA
You're welcome, Dale.

QUOTE
I'm getting the data from Govt website (HUD/FHA)...

Ah, it all makes sense now. (IMG:http://www.utteraccess.com/forum/style_emoticons/default/wary.gif) (IMG:http://www.utteraccess.com/forum/style_emoticons/default/ohyeah.gif)

It's been a while since I wrote a hack like that, it was a good practice. (IMG:http://www.utteraccess.com/forum/style_emoticons/default/wink.gif)
Go to the top of the page
 
+
norie
post Mar 1 2008, 10:59 AM
Post #5

UtterAccess VIP
Posts: 4,296
Here's another take.
CODE
Sub MoveInfo()

Dim wsNew As Worksheet

Dim rngDst As Range

Dim rngSrc As Range



    Set wsNew = Worksheets.Add

    

    Set rngDst = wsNew.Range("A2")

    Set rngSrc = Worksheets("Raw pasted data").Range("A1")

    

    While rngSrc.Value <> ""

        rngSrc.Resize(11).Copy

        rngDst.PasteSpecial Transpose:=True

        

        Set rngSrc = rngSrc.Offset(13)

        

        Set rngDst = rngDst.Offset(1)

        

    Wend

    

    wsNew.Columns(8).Delete

    wsNew.Columns(5).Delete

    wsNew.Columns(4).Delete



    With wsNew.Range("A1:H1")

        .Value = Array("Name", "Address", "City_St", "FHA Type", "Approval Date", "FHA specaility", "Telephone", "e-mail")

        .EntireColumn.AutoFit

    End With

    

End Sub

It relies on the fact that the data seems to be evenly distributed into blocks of a certain length and seperated uniformly.

And if you don't want a new sheet.
CODE
Sub MoveInfo()

Dim rngDst As Range

Dim rngSrc As Range



    With Worksheets("Raw pasted data")

        Set rngDst = .Range("B2")

        Set rngSrc = .Range("A1")

    

        While rngSrc.Value <> ""

            rngSrc.Resize(11).Copy

            rngDst.PasteSpecial Transpose:=True

            Set rngSrc = rngSrc.Offset(13)

            Set rngDst = rngDst.Offset(1)

        Wend

    

        .Columns(9).Delete

        .Columns(6).Delete

        .Columns(5).Delete

        .Columns(1).Delete

        

        With .Range("A1:H1")

            .Value = Array("Name", "Address", "City_St", "FHA Type", "Approval Date", "FHA specaility", "Telephone", "e-mail")

            .EntireColumn.AutoFit

        End With

    End With

    

End Sub

And here's another, seemingly faster version, using arrays.
CODE
Sub MoveInfo()

Dim rngDst As Range

Dim rngSrc As Range

Dim arrVals



    With Worksheets("Raw pasted data")

        Set rngDst = .Range("B2")

        Set rngSrc = .Range("A1")

    

        While rngSrc.Value <> ""

            arrVals = rngSrc.Resize(11)

            rngDst.Resize(, 11) = Application.Transpose(arrVals)

            Set rngSrc = rngSrc.Offset(13)

            Set rngDst = rngDst.Offset(1)

        Wend

    

        .Columns(9).Delete

        .Columns(6).Delete

        .Columns(5).Delete

        .Columns(1).Delete

        

        With .Range("A1:H1")

            .Value = Array("Name", "Address", "City_St", "FHA Type", "Approval Date", "FHA specaility", "Telephone", "e-mail")

            .EntireColumn.AutoFit

        End With

    End With

    

End Sub


PS if you're wondering, yes I am bored - it's a cold, windy, rainy March afternoon. (IMG:http://www.utteraccess.com/forum/style_emoticons/default/wink.gif)

Edited by: norie on Sat Mar 1 11:28:26 EST 2008.

Edited by: norie on Sat Mar 1 11:36:03 EST 2008.

Edited by: norie on Sat Mar 1 11:39:07 EST 2008.
Go to the top of the page
 
+
NateO
post Mar 1 2008, 02:54 PM
Post #6

Remembered
Posts: 5,055
From: Minneapolis, MN, USA
Hmmm, not sure why I didn't think to delete the extra columns instead of the couple of loops that I'm using.

My take isn't dependent on consistent row spacing, but if that is the case, and it looks like it is, that probably makes more sense.
Go to the top of the page
 
+
norie
post Mar 1 2008, 03:16 PM
Post #7

UtterAccess VIP
Posts: 4,296
Nate

Perhaps I'm misreading your code but I think it does seem to rely on the fact that the blocks of data are consistent.

Maybe based on finding the email part rather than a set number of row?

Anyways, it seems all the code posted so far works - ome faster than others.
Go to the top of the page
 
+
NateO
post Mar 1 2008, 03:21 PM
Post #8

Remembered
Posts: 5,055
From: Minneapolis, MN, USA
Hi Norie,

QUOTE
Perhaps I'm misreading your code but I think it does seem to rely on the fact that the blocks of data are consistent.

Nope, insert some random rows (make it inconsistent) and give it a shot.

You have to follow the logic of what I'm doing to understand, which might be convoluted, so I will summarize. The only thing that has to be consistent is that there has to be a row containing 'E-Mail Address' for each "Record", which appears to be a field name, so it looks like it's going to be there for each individual "Record".

Here's the logic: Remove all "Blank Rows" (have to get rid of spaces and crap first)->Insert a single row following the last field of each Record (E-Mail Address is our marker)-> Dynamically use the End Method on each Record which traps based on the blank rows we dynamically inserted.

It's actually pretty fast considering how much it is labouring, which is why I referred to it as a hack. What helps is that I minimized the last loop by only looking at the Intersect of Constants and Blanks. (IMG:http://www.utteraccess.com/forum/style_emoticons/default/wink.gif)
Go to the top of the page
 
+
KingMartin
post Mar 1 2008, 03:44 PM
Post #9

Retired Moderator
Posts: 10,959
From: Prague,CZ / Kiev,UA
QUOTE
What helps is that I minimized the last loop by only looking at the Intersect of Constants and Blanks.


...Which part I liked a lot. Intersect(Blanks, Constants.offset(-1))... hmmm... good trick how to return blanks above nonblanks regardless of the other blanks (IMG:http://www.utteraccess.com/forum/style_emoticons/default/thumbup.gif)

Martin
Go to the top of the page
 
+
NateO
post Mar 1 2008, 04:12 PM
Post #10

Remembered
Posts: 5,055
From: Minneapolis, MN, USA
QUOTE
...Which part I liked a lot. Intersect(Blanks, Constants.offset(-1))... hmmm... good trick how to return blanks above nonblanks regardless of the other blanks

I thank you for the kind feedback. Now that I think about it a little more, while it doesn't hurt in this case, it's not necessary as I reduced the data to one blank row per record anyways.

But in other cases, with multiple blank rows, it is a slick trick. I had never seen it before, and I generally use the Range's "_Default" property to Offset, as I've done here as well. Not that what I have done is ingenious, but to explain...

It occured to me one day that the Offset Property is the way to go when you need to shift in non-contiguous Ranges, Item and _Default are useless for this. So, I figured I had better test the Intersect Method on this concept and what d'ya know, it works like a charm.

Nice to see someone appreciated the madness to my method. o!

It's kind of nice having a big bag of applicable tricks we can use in many differing contexts, no? (IMG:http://www.utteraccess.com/forum/style_emoticons/default/sad.gif)
Go to the top of the page
 
+
KingMartin
post Mar 2 2008, 07:03 AM
Post #11

Retired Moderator
Posts: 10,959
From: Prague,CZ / Kiev,UA
QUOTE
the Offset Property is the way to go when you need to shift in non-contiguous Ranges

That's right, I use it for example when simulating update query of SQL. Here, column B updates to "ValueB" where column A has "B".

CODE
Dim rg As Range
With Sheet1
    Set rg = .Range("A2", .Cells(.Rows.Count, "A").End(3))
    With rg
        .Resize(1).Offset(-1).AutoFilter 1, "B"
        .SpecialCells(xlVisible).Offset(, 1).Value = "ValueB"
    End With
    .AutoFilterMode = False
End With


Martin
Go to the top of the page
 
+
« Next Oldest · Microsoft Excel · Next Newest »
 

Thank you for your support! Reply to this topicStart new topic

Jump To Forum:
 

Display Mode: Standard · Switch to: Linear+ · Switch to: Outline

Track this topic · Email this topic · Print this topic · Subscribe to this forum

RSS Go to Top  ·  Lo-Fi Version Time is now: 22nd May 2013 - 04:18 PM