Transpose Data

V

vanwooten

Board Regular
Joined
Dec 15, 2020
Messages
51
Office Version
  1. 365
Platform
  1. Windows
I have Excel data for area codes associated with zip codes that looks like this:

53050​
215​
267​
445​
484​
610​
835​
856​

I need the data to look like this:

53050​
215​
53050​
267​
53050​
445​
53050​
484​
53050​
610​
53050​
835​
53050​
856​

The zip codes have a varying number area codes associated. I have Access if a query would do it better. I also have some VBA experience. Any ideas?
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Sort by date Sort by votes
Like this ?

Excel Formula: 
=LET(d,B3:I3,a,CHOOSECOLS(d,1),b,DROP(d,,1),c,IFERROR(HSTACK(a,TRANSPOSE(b)),""),TRANSPOSE(SCAN("",TRANSPOSE(c),LAMBDA(a,b,IF(b<>"",b,a)))))

1717127720579.png
 
Upvote 0
With the information supplied, this is the closest I can see.
Code: 
Sub Maybe()
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
    sh2.Cells(1, 2).Resize(sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column - 1).Value = Application.Transpose(sh1.Cells(1, 2).Resize(, sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column - 1).Value)
    sh2.Cells(1, 1).Resize(sh1.Cells(1, sh1.Columns.Count).End(xlToLeft).Column - 1).Value = sh1.Cells(1, 1).Value
End Sub
 
Upvote 0
If you have multiple rows:

Book1
ABCDEFGHIJKLM
1
2
3ZIP CodeArea CodesZIP CodeArea codes
45305021553050215267445484610835856
55305026753060262
65305044553070123345678
75305048497123222333444555
85305061099901717818919
953050835
1053050856
1153060262
1253070123
1353070345
1453070678
1597123222
1697123333
1797123444
1897123555
1999901717
2099901818
2199901919
22
Sheet19
Cell Formulas
RangeFormula
A4:B21A4=LET(a,E4:E8,b,F4:M8,c,COUNTA(b),sr,SEQUENCE(ROWS(a)+1,,0),ca,IF(sr=0,0,SUBTOTAL(3,OFFSET(b,0,0,sr))),sa,SEQUENCE(COUNTA(b),,0),m,MATCH(sa,ca),CHOOSE({1,2},INDEX(a,m),INDEX(b,m,sa-INDEX(ca,m)+1)))
Dynamic array formulas.


But this might be better suited to VBA. If so try this:

VBA Code: 
[CODE]
Sub ReformatCodes()
Dim InCell As Range, OutCell As Range, dic As Object, r As Long, c As Long

    Set InCell = Sheets("Sheet19").Range("E3")
    Set OutCell = Sheets("Sheet19").Range("A3")
    
    OutCell.Resize(30000, 2).ClearContents
    OutCell.Resize(1, 2).Value = InCell.Resize(1, 2).Value
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    r = 1
    While InCell.Offset(r) <> ""
        c = 1
        While InCell.Offset(r, c) <> ""
            dic(InCell.Offset(r) & "|" & InCell.Offset(r, c)) = 1
            c = c + 1
        Wend
        r = r + 1
    Wend
    
    OutCell.Offset(1).Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    OutCell.Offset(1).Resize(dic.Count).TextToColumns Other:=True, OtherChar:="|"
    
End Sub
[CODE=vba]

Set the InCell and OutCell ranges at the top to the input table (including headers), and to where you want the results put.
 
Upvote 0
Code: 
Sub Maybe()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim c As Range, j As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
j = 1
For Each c In sh1.Range("A1:A" & sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row)
    sh2.Cells(1, j).Resize(sh1.Cells(c.Row, sh1.Columns.Count).End(xlToLeft).Column - 1).Value = c.Value
    sh2.Cells(1, j + 1).Resize(sh1.Cells(c.Row, sh1.Columns.Count).End(xlToLeft).Column - 1).Value = _
    Application.Transpose(sh1.Cells(c.Row, 2).Resize(, sh1.Cells(c.Row, sh1.Columns.Count).End(xlToLeft).Column - 1).Value)
    j = j + 2
Next c
End Sub

Clipboard01.jpg


Result in Sheet2

Clipboard02.jpg
 
Upvote 0
Book1
ABCDEFGHIJKL
1
2
3ZIP CodeArea CodesZIP CodeArea codes
45305021553050215267445484610835856
55305026753060262
65305044553070123345678
75305048497123222333444555
85305061099901717818919
953050835
1053050856
1153060262
1253070123
1353070345
1453070678
1597123222
1697123333
1797123444
1897123555
1999901717
2099901818
2199901919
Sheet2
Cell Formulas
RangeFormula
A4:B21A4=LET(c,BYROW(F4:L8,LAMBDA(r,COUNTA(r))),HSTACK(TOCOL(IFS(c>=SEQUENCE(,MAX(c)),E4:E8),2),TOCOL(F4:L8,1)))
Dynamic array formulas.
 
Upvote 0
Another option
Fluff.xlsm
ABCDEFGHIJKLMNO
1
2
3ZIP CodeArea CodesZIP CodeArea codes
45305021553050215267445484610835856
55305026753060262
65305044553070123345678
75305048497123222333444555
85305061099901717818919
953050835
1053050856
1153060262
1253070123
1353070345
1453070678
1597123222
1697123333
1797123444
1897123555
1999901717
2099901818
2199901919
22
Sheet6
Cell Formulas
RangeFormula
A4:B21A4=HSTACK(TOCOL(IF(F4:P10<>"",E4:E10,1/0),2),TOCOL(F4:P10,1))
Dynamic array formulas.
 
Upvote 0
Eric W said:
If you have multiple rows:

Book1
ABCDEFGHIJKLM
1
2
3ZIP CodeArea CodesZIP CodeArea codes
45305021553050215267445484610835856
55305026753060262
65305044553070123345678
75305048497123222333444555
85305061099901717818919
953050835
1053050856
1153060262
1253070123
1353070345
1453070678
1597123222
1697123333
1797123444
1897123555
1999901717
2099901818
2199901919
22
Sheet19
Cell Formulas
RangeFormula
A4:B21A4=LET(a,E4:E8,b,F4:M8,c,COUNTA(b),sr,SEQUENCE(ROWS(a)+1,,0),ca,IF(sr=0,0,SUBTOTAL(3,OFFSET(b,0,0,sr))),sa,SEQUENCE(COUNTA(b),,0),m,MATCH(sa,ca),CHOOSE({1,2},INDEX(a,m),INDEX(b,m,sa-INDEX(ca,m)+1)))
Dynamic array formulas.


But this might be better suited to VBA. If so try this:

VBA Code: 
[CODE]
Sub ReformatCodes()
Dim InCell As Range, OutCell As Range, dic As Object, r As Long, c As Long

    Set InCell = Sheets("Sheet19").Range("E3")
    Set OutCell = Sheets("Sheet19").Range("A3")
  
    OutCell.Resize(30000, 2).ClearContents
    OutCell.Resize(1, 2).Value = InCell.Resize(1, 2).Value
  
    Set dic = CreateObject("Scripting.Dictionary")
  
    r = 1
    While InCell.Offset(r) <> ""
        c = 1
        While InCell.Offset(r, c) <> ""
            dic(InCell.Offset(r) & "|" & InCell.Offset(r, c)) = 1
            c = c + 1
        Wend
        r = r + 1
    Wend
  
    OutCell.Offset(1).Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    OutCell.Offset(1).Resize(dic.Count).TextToColumns Other:=True, OtherChar:="|"
  
End Sub
[CODE=vba]

Set the InCell and OutCell ranges at the top to the input table (including headers), and to where you want the results put.
Click to expand...
I have 41119 zip codes. This VBA creates
Eric W said:
If you have multiple rows:

Book1
ABCDEFGHIJKLM
1
2
3ZIP CodeArea CodesZIP CodeArea codes
45305021553050215267445484610835856
55305026753060262
65305044553070123345678
75305048497123222333444555
85305061099901717818919
953050835
1053050856
1153060262
1253070123
1353070345
1453070678
1597123222
1697123333
1797123444
1897123555
1999901717
2099901818
2199901919
22
Sheet19
Cell Formulas
RangeFormula
A4:B21A4=LET(a,E4:E8,b,F4:M8,c,COUNTA(b),sr,SEQUENCE(ROWS(a)+1,,0),ca,IF(sr=0,0,SUBTOTAL(3,OFFSET(b,0,0,sr))),sa,SEQUENCE(COUNTA(b),,0),m,MATCH(sa,ca),CHOOSE({1,2},INDEX(a,m),INDEX(b,m,sa-INDEX(ca,m)+1)))
Dynamic array formulas.


But this might be better suited to VBA. If so try this:

VBA Code: 
[CODE]
Sub ReformatCodes()
Dim InCell As Range, OutCell As Range, dic As Object, r As Long, c As Long

    Set InCell = Sheets("Sheet19").Range("E3")
    Set OutCell = Sheets("Sheet19").Range("A3")
   
    OutCell.Resize(30000, 2).ClearContents
    OutCell.Resize(1, 2).Value = InCell.Resize(1, 2).Value
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    r = 1
    While InCell.Offset(r) <> ""
        c = 1
        While InCell.Offset(r, c) <> ""
            dic(InCell.Offset(r) & "|" & InCell.Offset(r, c)) = 1
            c = c + 1
        Wend
        r = r + 1
    Wend
   
    OutCell.Offset(1).Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    OutCell.Offset(1).Resize(dic.Count).TextToColumns Other:=True, OtherChar:="|"
   
End Sub
[CODE=vba]

Set the InCell and OutCell ranges at the top to the input table (including headers), and to where you want the results put.
Click to expand...
I have 41119 zip code records. This VBA produces 74423 records, which may be the correct number. However, it produced only #N/A after record 8887. All of the correctly converted records had only one area code per zip but that was also the case for thousands of #N/A records before we got to multiple area code records.

1717172161712.png
 
Upvote 0
Sorry, I underestimated the number of results. The TRANSPOSE function has a limit. This version will allow up to 100000 output rows, which can be easily raised if necessary.

VBA Code: 
Sub ReformatCodes()
Dim InCell As Range, OutCell As Range, r As Long, c As Long
Dim op(1 To 100000, 1 To 2), r2 As Long

    Set InCell = Sheets("Sheet19").Range("E3")
    Set OutCell = Sheets("Sheet19").Range("A3")
    
    OutCell.Resize(1, 2).Value = InCell.Resize(1, 2).Value
    
    r = 1
    r2 = 1
    While InCell.Offset(r) <> ""
        c = 1
        While InCell.Offset(r, c) <> ""
            op(r2, 1) = InCell.Offset(r)
            op(r2, 2) = InCell.Offset(r, c)
            r2 = r2 + 1
            If r2 > 100000 Then
                MsgBox "Number of output rows is over 100000."
                Exit Sub
            End If
            c = c + 1
        Wend
        r = r + 1
    Wend
        
    OutCell.Offset(1).Resize(100000, 2) = op
End Sub
 
Upvote 0
Eric W said:
Sorry, I underestimated the number of results. The TRANSPOSE function has a limit. This version will allow up to 100000 output rows, which can be easily raised if necessary.

VBA Code: 
Sub ReformatCodes()
Dim InCell As Range, OutCell As Range, r As Long, c As Long
Dim op(1 To 100000, 1 To 2), r2 As Long

    Set InCell = Sheets("Sheet19").Range("E3")
    Set OutCell = Sheets("Sheet19").Range("A3")
   
    OutCell.Resize(1, 2).Value = InCell.Resize(1, 2).Value
   
    r = 1
    r2 = 1
    While InCell.Offset(r) <> ""
        c = 1
        While InCell.Offset(r, c) <> ""
            op(r2, 1) = InCell.Offset(r)
            op(r2, 2) = InCell.Offset(r, c)
            r2 = r2 + 1
            If r2 > 100000 Then
                MsgBox "Number of output rows is over 100000."
                Exit Sub
            End If
            c = c + 1
        Wend
        r = r + 1
    Wend
       
    OutCell.Offset(1).Resize(100000, 2) = op
End Sub
Click to expand...
Perfect. Thank You.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
Sorting data
2
Replies
19
Views
657
hagia_sofia
hagia_sofia
T
  • Question
help with data shared between tables
Replies
0
Views
192
The_Flapjack
T
D
  • Question
Excel USPS Zip Code Chart
Replies
3
Views
579
Scott Huish
Scott Huish
J
  • Question
Turning a template area to transition data into a running list
Replies
0
Views
105
JBG9207
J
L
  • Solved
User Selected Variables
Replies
2
Views
333
Jeffrey Mahoney
Jeffrey Mahoney

Forum statistics

Threads
1,221,867
Messages
6,162,523
Members
451,773
Latest member
ssmith04

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top