I am having Zip Code Replacement Issues Excel VBA

Macro needs to replace a set of zip codes that will be in column C. For other zip codes replace them, and add in another zip at the bottom of column C (1 zip code turns into 2 zip codes on the list). Then copy all of the zip codes for me to paste into another application.

I am a complete novice at coding (haven't done any in 20 years, even then only the smallest of dabbling in it). So the code I have is a Frankenstein of recorded macros, code copy and pasted off of websites, and sloppy edits I have made.

I am running into 2 issues:

The section that replaces solo zip codes seems to work fine. The main issue seems to be when trying to find if there are zip codes that need to become 2 zip codes, the macro seems to crash if one of those zip codes isn't present in the document. The data in this list changes every day, and sometimes those zip codes won't be present. I need it to continue working if the zip codes its trying to find, replace, and add are not there.
Zip codes seem to be a nightmare in excel (due to leading 0's). I can't figure out why leading 0's are being dropped with certain things I am doing and not others.

I have tried recording a macro to find the zip codes I need and replace them. It works exactly as expected if every possible zip code I would need to modify is in the document, but otherwise crashes without changing the rest of the zip codes and copying the column for me.

I have tried removing the "find" part of my initial macro and just leaving the "replace" section (I think it was redundant to what I was trying to do). It didn't seem to make a difference.

I have tried adding if then's as I suspect they might be a solution, but cannot wrap my head around what kinds of things can be put in what spot of the syntax and how to utilize them to do what I need.

Here is the code

Sub Zipcode1()
    'Replaces Uselss Zip Codes with Delivery Offices
    Range("c:c").Replace What:="06042", Replacement:="'06040"
    Range("c:c").Replace What:="06610", Replacement:="'06602"
    Range("c:c").Replace What:="06013", Replacement:="'06013"
    Range("c:c").Replace What:="06850", Replacement:="'06854"
    Range("c:c").Replace What:="06447", Replacement:="'06424"
    
    'Replace 06851 > 06854 and 06856
'        Cells.Find(What:="06851", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
'        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
'        False, SearchFormat:=False).Activate
'    Cells.Replace What:="06851", Replacement:="'06854", LookAt:=xlPart, _
'        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
'        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'    Selection.End(xlDown).Select
'    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
'    ActiveCell.FormulaR1C1 = "'06856"
'    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select

'        Cells.Find(What:="06851", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
'        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
'        False, SearchFormat:=False).Activate
    If Range(C, C).Value = "06851" Then
    Cells.Replace What:="06851", Replacement:="06854", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True, FormulaVersion:=xlReplaceFormula2
    Range("C2").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
    ActiveCell.FormulaR1C1 = "6856"
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "06856"
    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
    End If
     
        'Replace 06910 > 06907 and 06902
'        Cells.Find(What:="06910", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
'        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
'        False, SearchFormat:=False).Activate
'    Cells.Replace What:="06910", Replacement:="'06902", LookAt:=xlPart, _
'        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
'        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'    Selection.End(xlDown).Select
'    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
'    ActiveCell.FormulaR1C1 = "'06907"
'    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
    Cells.Replace What:="06910", Replacement:="06902", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True, FormulaVersion:=xlReplaceFormula2
    Range("C2").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
    ActiveCell.FormulaR1C1 = "6907"
    ActiveCell.Select
    ActiveCell.FormulaR1C1 = "06907"
    ActiveCell.Offset(1, 0).Range("InitialContactTable[[#Headers],[MPOO]]").Select
        
    'Realigns C
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("InitialContactTable[[#Headers],[Facili0y ZIP Code]]").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
     
    'Obliterates empty rows so they don't get copied
    Dim rng As Range
    Dim i As Long
    Set rng = ActiveSheet.UsedRange
    For i = rng.Rows.Count To 1 Step -1
        If Application.WorksheetFunction.CountA(rng.Rows(i)) = 0 Then
            rng.Rows(i).EntireRow.Delete
        End If
    Next i
    
    'Copies Zipcodes
    Range("C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
End Sub

Solution

Try this out:

Sub PerformZipReplacements()

    Dim lc As ListColumn
    
    Set lc = ActiveSheet.ListObjects("InitialContactTable").ListColumns("Facility ZIP Code")
    
    ReplaceInColumn lc, "blah1", "new1"  'one ZIP to one  ZIP
    
    ReplaceInColumn lc, "blah4", "new4A", "new4B" 'one ZIP to two ZIPs
    
    ReplaceInColumn lc, "notThere", "newVal"   'test non-existant value
    
    ReplaceInColumn lc, "blah6", "new6A", "blah6", "new6C" 'one ZIP to three ZIPs (one same)
    
End Sub


Sub ReplaceInColumn(lc As ListColumn, findVal As String, _
                                ParamArray newVals() As Variant)
    
    Dim lb As Long, i As Long, r As Long, data As Variant
    
    lc.Range.NumberFormat = "@" 'ensure "Text" format
    data = lc.Range.Value 'read to array for performance

    'loop backwards over data to avoid issues with inserted rows
    For r = UBound(data, 1) To 1 Step -1
        If data(r, 1) = findVal Then 'match?
            For i = 0 To UBound(newVals)
                If i = 0 Then  'first replacement?
                    lc.Range.Cells(r).Value = newVals(i)
                Else
                    lc.Parent.ListRows.Add r + (i - 1)       'add a row to the list
                    lc.Range.Cells(r + i).Value = newVals(i) 'add the ZIP to the new row
                End If
            Next i
        End If
    Next r
End Sub

My test table "Before" and "After":