Full Version: Macro to move 1 column of data to multiple columns
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.
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:
I'd explain it, but I'm not quite sure where to start, or stop for that matter.
Merry Christmas.
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
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.
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
Dale
You're welcome, Dale.
Ah, it all makes sense now.
It's been a while since I wrote a hack like that, it was a good practice.
QUOTE
I'm getting the data from Govt website (HUD/FHA)...
Ah, it all makes sense now.
It's been a while since I wrote a hack like that, it was a good practice.
Here's another take.
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.
And here's another, seemingly faster version, using arrays.
PS if you're wondering, yes I am bored - it's a cold, windy, rainy March afternoon.
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.
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
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
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
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.
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.
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.
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.
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.
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.
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.
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.
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
Martin
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?
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
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.