You are here:

Excel/Transpose with a twist

Advertisement


Question
Transpose with a twist
Transpose with a twist  
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 ----------

Problem with transpose
Problem with transpose  
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 ----------

4Jerry3
4Jerry3  

4Jerry4
4Jerry4  
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"

Answer
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
About Excel
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

All Answers


Answers by Expert:


Ask Experts

Volunteer


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

©2016 About.com. All rights reserved.