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
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
- 2 "if there are zip codes that need to become 2 zip codes" if you were doing that manually what would be the steps to do that? – Tim Williams Commented Feb 6 at 17:34
- I originally tried selecting the entire row, copying it, and then finding the bottom row, and pasting it down there. Then changing the zip code in column C in the original row to one zip code, and column C in the new column to the 2nd zip code I need. This is the part I found redundant. What I am now trying to do is change column C to one zip code, then go to the last row, go down 1 more row, and add the other zip code to column C (so the same thing, but not copying the whole row as well). When I get to the point of needing the 2nd zip code I really only need column C in this document. – Eric Commented Feb 6 at 17:42
1 Answer
Reset to default 2Try 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":