You are here:

- Home
- Computing/Technology
- Business Software
- Excel
- Transpose with a twist

Advertisement

QUESTION: Hello Jerry,

I have a transposition question, but with a twist.

Please see the attached image.

I think that explains everything clearly.

I have considered fancy lookups, index/match, and vba - all to no avail.

I'm not an expert vba guy like you, and I'm guessing this definitely needs a vba solution.

Thanks for your efforts, Jerry!

- Al Baker

ANSWER: Hi Al,

This macro should be near on instantaneous, even with 30k rows of data. Just drop the data in columns A:B, it will do the rest.

Option Explicit Sub ReformatData() 'Looks for f1,f2,f3,f4 in column A data and sets up a 4 column output Dim MyArr1 As Variant, i As Long Dim MyArr2 As Variant, NR As Long, LR As Long With ActiveSheet LR = .Range("A" & .Rows.Count).End(xlUp).Row MyArr1 = .Range("A1:B" & LR).Value ReDim MyArr2(1 To LR, 1 To 4) NR = 1 MyArr2(1, 1) = "f1" MyArr2(1, 2) = "f2" MyArr2(1, 3) = "f3" MyArr2(1, 4) = "f4" For i = LBound(MyArr1) To UBound(MyArr1) Select Case MyArr1(i, 1) Case "f1" NR = NR + 1 MyArr2(NR, 1) = MyArr1(i, 2) Case "f2" MyArr2(NR, 2) = MyArr1(i, 2) Case "f3" MyArr2(NR, 3) = MyArr1(i, 2) Case "f4" MyArr2(NR, 4) = MyArr1(i, 2) Case Else 'do nothing End Select Next i .Range("D:G").Clear .Range("D1:G" & LR).Value = MyArr2 .Range("D1").CurrentRegion.Borders.Weight = xlThin .Range("D1:G1").Interior.ColorIndex = 6 .Range("D:G").Columns.AutoFit End With End Sub

http://tinyurl.com/JerryBeaucaire

---------- FOLLOW-UP ----------

QUESTION: Hello Jerry,

Your solution is BRILLIANT !

However, there seems to be one glitch:

In the attached image, you can see that I added a new (5th) record to my list in cols A-B. This time, I switched the fields around as you can see. When I populated my fields in cols D-G by running your macro, the 1st 3 records populated correctly, but the 4th and 5th did not.

Hope this makes sense.

Thanks, Jerry !

ANSWER: OK, your original question didn't indicate this jumbling, so we were using instances of F1 to indicate the start of a new output row. I've changed the way this works and base the new rows on the existence of any F1/F2/F3/F4 after a blank row. Try this:

Option Explicit Sub ReformatData() 'Looks for f1,f2,f3,f4 in column A data and sets up a 4 column output Dim MyArr1 As Variant, i As Long Dim MyArr2 As Variant, NR As Long, LR As Long, Blanks As Boolean With ActiveSheet LR = .Range("A" & .Rows.Count).End(xlUp).Row MyArr1 = .Range("A1:B" & LR).Value ReDim MyArr2(1 To LR, 1 To 4) NR = 1 MyArr2(1, 1) = "f1" MyArr2(1, 2) = "f2" MyArr2(1, 3) = "f3" MyArr2(1, 4) = "f4" For i = LBound(MyArr1) To UBound(MyArr1) Select Case MyArr1(i, 1) Case "f1" If Blanks Then NR = NR + 1 Blanks = False End If MyArr2(NR, 1) = MyArr1(i, 2) Case "f2" If Blanks Then NR = NR + 1 Blanks = False End If MyArr2(NR, 2) = MyArr1(i, 2) Case "f3" If Blanks Then NR = NR + 1 Blanks = False End If MyArr2(NR, 3) = MyArr1(i, 2) Case "f4" If Blanks Then NR = NR + 1 Blanks = False End If MyArr2(NR, 4) = MyArr1(i, 2) Case Else Blanks = True End Select Next i .Range("D:G").Clear .Range("D1:G" & LR).Value = MyArr2 .Range("D1").CurrentRegion.Borders.Weight = xlThin .Range("D1:G1").Interior.ColorIndex = 6 .Range("D:G").Columns.AutoFit End With End Sub

http://tinyurl.com/JerryBeaucaire

---------- FOLLOW-UP ----------

QUESTION: Jerry,

Thank you so much for your time and expertise.

I apologize for not being as precise as I should have.

I was trying to "simplify" the actual example but in doing so, I left out important information which you needed.

Again, please accept my apologies.

I will be more clear. Please see the attached - there are 2 images.

The first re-states my example and objective, along with a bit of background.

The second shows the result of running your solution - which is VERY CLOSE.

You wrote your code so well that I thought I could edit it in order to accommodate more fields. I thought I edited it properly by putting in "field one" rather the f1, and by adding a 5th field but perhaps I did something wrong.

Your code which I modified is below:

Option Explicit

Sub ReformatData()

'Looks for f1,f2,f3,f4 in column A data and sets up a 4 column output

'modified to add a 5th field as well as actual field names

Dim MyArr1 As Variant, i As Long

Dim MyArr2 As Variant, NR As Long, LR As Long, Blanks As Boolean

With ActiveSheet

LR = .Range("A" & .Rows.Count).End(xlUp).Row

MyArr1 = .Range("A1:B" & LR).Value

ReDim MyArr2(1 To LR, 1 To 5)

NR = 1

MyArr2(1, 1) = "field one"

MyArr2(1, 2) = "field two"

MyArr2(1, 3) = "field three"

MyArr2(1, 4) = "field four"

MyArr2(1, 5) = "field five"

For i = LBound(MyArr1) To UBound(MyArr1)

Select Case MyArr1(i, 1)

Case "field one"

If Blanks Then

NR = NR + 1

Blanks = False

End If

MyArr2(NR, 1) = MyArr1(i, 2)

Case "field two"

If Blanks Then

NR = NR + 1

Blanks = False

End If

MyArr2(NR, 2) = MyArr1(i, 2)

Case "field three"

If Blanks Then

NR = NR + 1

Blanks = False

End If

MyArr2(NR, 3) = MyArr1(i, 2)

Case "field four"

If Blanks Then

NR = NR + 1

Blanks = False

End If

MyArr2(NR, 4) = MyArr1(i, 2)

Case "field five"

If Blanks Then

NR = NR + 1

Blanks = False

End If

MyArr2(NR, 5) = MyArr1(i, 2)

Case Else

Blanks = True

End Select

Next i

.Range("D3:H99999").Clear

.Range("D2:H" & LR).Value = MyArr2

.Range("D2").CurrentRegion.Borders.Weight = xlThin

.Range("D2:H2").Interior.ColorIndex = 6

' .Range("D:H").Columns.AutoFit

End With

End Sub

Thank you again Jerry for your incredible expertise, promptness, and patience.

- Al"

So far, you've expanded the samples each time to a new level of complexity that has, I think, finally passed the doable line.

1) A group of values that go together can be jumbled, so we can't just start a new row each time we see "field one". So we'll use junk text to start a new row.

2) junk text now also appears in the middle of a group, possibly jumbled, so we can't reliable use junk text to indicate the start of new section.

Skipping blanks is easy. But this new #2 above ends my ideas on how to know when it's time to start a new row and always get it right.

Here's the new code that includes handling the blanks, but #2 means we'll still see some sections split amongst two rows. You'll see.

Option Explicit Sub ReformatData() 'Looks for f1,f2,f3,f4 in column A data and sets up a 4 column output 'modified to add a 5th field as well as actual field names Dim MyArr1 As Variant, i As Long Dim MyArr2 As Variant, NR As Long, LR As Long, Other As Boolean With ActiveSheet LR = .Range("A" & .Rows.Count).End(xlUp).Row MyArr1 = .Range("A1:B" & LR).Value ReDim MyArr2(1 To LR, 1 To 5) NR = 1 MyArr2(1, 1) = "Company" MyArr2(1, 2) = "Email" MyArr2(1, 3) = "Phone" MyArr2(1, 4) = "tib" MyArr2(1, 5) = "Dollars" For i = LBound(MyArr1) To UBound(MyArr1) Select Case MyArr1(i, 1) Case "field one" If Other Then NR = NR + 1 Other = False End If MyArr2(NR, 1) = MyArr1(i, 2) Case "field two" If Other Then NR = NR + 1 Other = False End If MyArr2(NR, 2) = MyArr1(i, 2) Case "field three" If Other Then NR = NR + 1 Other = False End If MyArr2(NR, 3) = MyArr1(i, 2) Case "field four" If Other Then NR = NR + 1 Other = False End If MyArr2(NR, 4) = MyArr1(i, 2) Case "field five" If Other Then NR = NR + 1 Other = False End If MyArr2(NR, 5) = MyArr1(i, 2) + 0 Case "" 'do nothing Case Else Other = True End Select Next i .Range("D:H").Clear .Range("D1:H" & LR).Value = MyArr2 .Range("D1").CurrentRegion.Borders.Weight = xlThin .Range("D1:H1").Interior.ColorIndex = 6 .Range("D:H").Columns.AutoFit .Range("H:H").Style = "Currency" End With End Sub

http://tinyurl.com/JerryBeaucaire

- Add to this Answer
- Ask a Question

Rating(1-10) | Knowledgeability = 10 | Clarity of Response = 10 | Politeness = 10 |

Comment | Jerry, I greatly appreciate your time and efforts on this. Your original solution was excellent. I have found what I needed however. Thanks again. |

This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

Answers by Expert:

Excel Formulas, macros, automation. Microsoft Excel MVP - 2010. Code site with free code snippets and techniques: http://sites.madrocketscientist.com/jerrybeaucaires-excelassistant/files

Microsoft Excel MVP - 2010. I have my own extensive Excel help/code site: http://sites.madrocketscientist.com/jerrybeaucaires-excelassistant/files
=====================
I have been offering free assistance as an Excel aid on many web sites for many years:
(http://www.excelforum.com - JBeaucaire) ======== (http://www.askmehelpdesk.com/spreadsheets - JBeaucaire) ======= (http://www.mrexcel.com/forum - jbeaucaire)**Education/Credentials**

Bachelor's Degree from Azusa Pacific University in Mathematics and Music Composition**Awards and Honors**

Microsoft Excel MVP 2010