List of zip codes by org code into ranges

[jfm2143]

Hello,

This is my first time using this forum so please be gentle. Your time and help would be greatly appreciated.

I've built a list of all zip codes in the US with their corresponding organization code, of which there are ~100. A total of ~42k rows.

I now need to group the data in a format consisting of a range of zip codes in each org, with a starting zip code and ending zip code. These ranges need to skip any zip codes not listed. So if a New York org went; 12540, 12541, 12542, 12543... on to 12553 then skipped to 12555, then to 12563 and carried on 12564, 15565... to 12572 the ranges would be 12540-12553, 12555 - 12555, 12563 - 12572. Below is an example of my data set and the format I need it in.

What I have:

Zip Code	State	Org
12541	New York	3905
12542	New York	3905
12543	New York	3905
12544	New York	3905
12545	New York	3905
12546	New York	3905
12547	New York	3905
12548	New York	3905
12549	New York	3905
12550	New York	3905
12551	New York	3905
12552	New York	3905
12553	New York	3905
12555	New York	3905
12561	New York	3905
12563	New York	3905
12564	New York	3905
12565	New York	3905
12566	New York	3905
12567	New York	3905
12568	New York	3905
12569	New York	3905
12570	New York	3905
12571	New York	3905
12572	New York	3905
12574	New York	3905
12575	New York	3905
12577	New York	3905
12578	New York	3905
12580	New York	3905
12581	New York	3905
501	New York	3901
544	New York	3901
10001	New York	3901
10002	New York	3901
10003	New York	3901
10004	New York	3901
10005	New York	3901
10006	New York	3901
10007	New York	3901
10008	New York	3901
10009	New York	3901
10010	New York	3901
10011	New York	3901
10012	New York	3901
10013	New York	3901
10014	New York	3901
10016	New York	3901
10017	New York	3901
10018	New York	3901

<colgroup><col><col><col></colgroup><tbody>
</tbody>

What I need:

STATE	FROM_POSTAL_CODE	TO_POSTAL_CODE	ORG_CODE
New York	12540	12553	3905
New York	12555	12555	3905
New York	12561	12561	3905
New York	12563	12572	3905
New York	12574	12575	3905
New York	12577	12578	3905
New York	501	501	3901
New York	544	544	3901
New York	10001	10048	3901
New York	10055	10055	3901
New York	10060	10060	3901
New York	10065	10065	3901

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

I've been spinning my wheels on this for over a week. This is my last ditch effort before pushing back and admitting I can't do this.

 

[MickG]

Give this a try for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG24Aug53
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, ray [COLOR="Navy"]As[/COLOR] Variant, Dn [COLOR="Navy"]As[/COLOR] Range, oMin [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Fst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRay() [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
oMin = Application.Min(Rng)
oMax = Application.Max(Rng)
ReDim ray(oMin - 1 To oMax + 1, 1 To 3)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    ray(Dn.Value, 1) = True
    ray(Dn.Value, 2) = Dn.Offset(, 2).Value
    ray(Dn.Value, 3) = Dn.Offset(, 1).Value
[COLOR="Navy"]Next[/COLOR] Dn
 
 c = 1
 ReDim nRay(1 To 4, 1 To 1)
nRay(1, 1) = "STATE": nRay(2, 1) = "FROM_POSTAL_CODE": nRay(3, 1) = "TO_POSTAL_CODE": nRay(4, 1) = "ORG_CODE"

[COLOR="Navy"]For[/COLOR] n = oMin To oMax
    [COLOR="Navy"]If[/COLOR] ray(n, 1) <> "" And ray(n - 1, 1) = "" [COLOR="Navy"]Then[/COLOR] Fst = n
    [COLOR="Navy"]If[/COLOR] ray(n, 1) <> "" And ray(n + 1, 1) = "" [COLOR="Navy"]Then[/COLOR] Lst = n
        [COLOR="Navy"]If[/COLOR] Fst <> 0 And Lst <> 0 [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            ReDim Preserve nRay(1 To 4, 1 To c)
            nRay(1, c) = ray(Fst, 3)
            nRay(2, c) = Fst
            nRay(3, c) = Lst
            nRay(4, c) = ray(Fst, 2)
            Fst = 0: Lst = 0
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, 4)
    .Value = Application.Transpose(nRay)
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Joe4]

Welcome to the Board!

Here is my stab at it ( have been messing around with it for a little while).
I sorted the data first. If you want this to happen on a different page (and keep the original data "as-is"), simply add code to copy and paste all the data to a new sheet.

Sub MyMacro()

    Dim lr As Long
    Dim r As Long

    Application.ScreenUpdating = False

'   Capture last row
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Sort by columns B, C, then A
    Range("A1:C" & lr).Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("C1") _
        , Order2:=xlAscending, Key3:=Range("A1"), Order3:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    
'   Insert columns, move columns around, add titles, and format
    Columns("C:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("A:A").Copy
    Range("C1:D1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("A:A").Delete Shift:=xlToLeft
    Range("B1") = "FROM_POSTAL_CODE"
    Range("C1") = "TO_POSTAL_CODE"
    Columns("B:C").EntireColumn.AutoFit

'   Loop through data
    r = 3
    Do Until Cells(r, "A") = ""
'       Check to see if columns A and D are the same as row above
        If (Cells(r, "A") = Cells(r - 1, "A")) And (Cells(r, "D") = Cells(r - 1, "D")) Then
'           Check to see if ending postal code is one more than row above
            If Cells(r, "C") - Cells(r - 1, "C") = 1 Then
'               Update ending value in row above and delete row
                Cells(r - 1, "C") = Cells(r, "C")
                Rows(r).Delete
            Else
'               Move down 1 row
                r = r + 1
            End If
        Else
'           Move down 1 row
            r = r + 1
        End If
    Loop

    Application.ScreenUpdating = True

End Sub

 

[jfm2143]

Thank you so much! I got your solution to work for me perfectly! You've done me a serious solid here, Joe4. Thank you for sharing your time and knowledge!

 

[jfm2143]

Hey MickG thank you so much! As a new member of this community, I'm so blown away to have received TWO solutions that worked perfectly! You and Joe4 have both done me a solid here, thank you for your time and know how.

 

[Joe4]

You are welcome.
Glad we were able to help.

 

[MickG]

You're very welcome.