Transpose Data

[vanwooten]

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?

 

[Eric W]

Glad we could help.

 

[vanwooten]

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.

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

Here is another question. I now have a two column list of zip/area code combinations. What I need is a unique list of area codes with an associated Zip. This zip can be any single zip in this new two column list that is associated with the area code. Trying to produce a geographic heat map from our members' area codes since we don't have their zips.

Perfect. Thank You.

If we could reverse the original process and use this new data set to create a data set that has distinct area code as the first column followed by a horizontal list of zips I could simply take the first column of zips.

 

[Eric W]

See if this works for you:

Sub ZIPsInAreaCode()
Dim InputCell As Range, OutputCell As Range, tbl As Variant
Dim lr As Long, last As Long, i As Long, r As Long, c As Long

    Set InputCell = Sheets("Sheet20").Range("A3")
    Set OutputCell = Sheets("Sheet20").Range("D3")
    
    lr = InputCell.End(xlDown).Row - InputCell.Row + 1
    tbl = WorksheetFunction.Sort(InputCell.Offset(1).Resize(lr - 1, 2), Array(2, 1), Array(1, 1))
    
    Application.ScreenUpdating = False
    OutputCell.Offset(, 1) = InputCell
    OutputCell = InputCell.Offset(, 1)
    
    last = -1
    c = 1
    r = 0
    For i = 1 To UBound(tbl)
        If tbl(i, 2) <> last Then
            r = r + 1
            c = 1
            last = tbl(i, 2)
            OutputCell.Offset(r) = tbl(i, 2)
        End If
        OutputCell.Offset(r, c) = tbl(i, 1)
        c = c + 1
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

It turns this A3 table to the D3 table:

Book1
	A	B	C	D	E	F	G	H
1
2
3	ZIP Code	Area codes		Area codes	ZIP Code
4	53050	123		123	53050	53070	97123
5	53050	267		222	97123
6	53050	456		262	53060
7	53050	484		267	53050
8	53050	610		333	97123
9	53050	835		456	53050	53070	99901
10	53050	856		484	53050
11	53060	262		610	53050
12	53070	456		678	53070	97123
13	53070	123		717	99901
14	53070	678		835	53050
15	97123	222		856	53050
16	97123	333		919	99901
17	97123	123		919	99901
18	97123	678
19	99901	717
20	99901	456
21	99901	919
22
Sheet20

 

[vanwooten]

Glad we could help.

See if this works for you:

Sub ZIPsInAreaCode()
Dim InputCell As Range, OutputCell As Range, tbl As Variant
Dim lr As Long, last As Long, i As Long, r As Long, c As Long

    Set InputCell = Sheets("Sheet20").Range("A3")
    Set OutputCell = Sheets("Sheet20").Range("D3")
   
    lr = InputCell.End(xlDown).Row - InputCell.Row + 1
    tbl = WorksheetFunction.Sort(InputCell.Offset(1).Resize(lr - 1, 2), Array(2, 1), Array(1, 1))
   
    Application.ScreenUpdating = False
    OutputCell.Offset(, 1) = InputCell
    OutputCell = InputCell.Offset(, 1)
   
    last = -1
    c = 1
    r = 0
    For i = 1 To UBound(tbl)
        If tbl(i, 2) <> last Then
            r = r + 1
            c = 1
            last = tbl(i, 2)
            OutputCell.Offset(r) = tbl(i, 2)
        End If
        OutputCell.Offset(r, c) = tbl(i, 1)
        c = c + 1
    Next i
   
    Application.ScreenUpdating = True
   
End Sub

It turns this A3 table to the D3 table:

Book1
	A	B	C	D	E	F	G	H
1
2
3	ZIP Code	Area codes		Area codes	ZIP Code
4	53050	123		123	53050	53070	97123
5	53050	267		222	97123
6	53050	456		262	53060
7	53050	484		267	53050
8	53050	610		333	97123
9	53050	835		456	53050	53070	99901
10	53050	856		484	53050
11	53060	262		610	53050
12	53070	456		678	53070	97123
13	53070	123		717	99901
14	53070	678		835	53050
15	97123	222		856	53050
16	97123	333		919	99901
17	97123	123		919	99901
18	97123	678
19	99901	717
20	99901	456
21	99901	919
22
Sheet20

Thanks again.