Full Version: Macro to move 1 column of data to multiple columns
UtterAccess Discussion Forums > Microsoft® Office > Microsoft Excel
dcochran
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.
NateO
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. wink.gif
dcochran
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
NateO
You're welcome, Dale.

Ah, it all makes sense now. wary.gif ohyeah.gif

It's been a while since I wrote a hack like that, it was a good practice. wink.gif
norie
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. 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.
NateO
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.
norie
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.
NateO
Hi Norie,

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. wink.gif
KingMartin
>
...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 thumbup.gif

Martin
NateO
/>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? sad.gif
KingMartin
>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
This is a "lo-fi" version of our main content. To view the full version with more information, formatting and images, please click here.