You are here:

# Excel/Transpose with a twist

Question

Transpose with a twist
QUESTION: Hello Jerry,
I have a transposition question, but with a twist.
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.
- Al Baker

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 ----------

Problem with transpose
QUESTION: Hello Jerry,
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.

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
Questioner's Rating
 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

#### Jerry Beaucaire

##### Expertise

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

##### Experience

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