Macro That Detects More than 5 characters in Cell (zip code) - excel

Question

I have created a function that retrieves a Range based on column name. Here is my code:
Sub sep_Filter()
Dim zip_rng As String
With Sheet2
zip_rng = getColRangeFunction("postalcode")
If Len(Range(zip_rng)) > 5 Then
Range(zip_rng).Interior.Color = RGB(255, 0, 0)
Range(zip_rng).Select
Else
Range(zip_rng).Interior.Color = xlNone
End If
End With
End Sub
Sheet2 Input Column D
Sheet2 Output Column D
Sheet3 Output Column D
088762598
088762598
06610-5000
06610-5000
330161898
330161898
970152880
970152880
112202570
112202570
127420800
127420800
062262040
062262040
07631
07631
10029
10029
11803
11803
99336
99336

Answer 1

EDIT I misunderstood what you were asking, I updated my answer to be tied to your question.
Here's a basic approach that will do what you're asking. It skips row one.
Sub onlyfirst5()
Const pRange As String = "D1"
Dim ws As Worksheet
Set ws = ActiveSheet
Dim crng As Range, cValues()
Set crng = Intersect(ws.UsedRange.Offset(1, 0), ws.UsedRange, ws.Range("D:D"))
cValues = crng.Value
Dim i As Long, j As Long
For i = LBound(cValues) To UBound(cValues)
For j = LBound(cValues, 2) To UBound(cValues, 2)
cValues(i, j) = Left(cValues(i, j), 5)
Next j
Next i
'for same sheet different column
ws.Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
'different sheet
Sheets("Sheet2").Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
'different file
Workbooks("Zip Code Question.xlsb").Sheets("Sheet3").Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
End Sub

Answer 2

Copy Entire Rows If Criteria Met
Option Explicit
Sub Postal5()
' Define constants.
Const srcName As String = "Sheet2"
Const srcFirst As String = "D2"
Const dstName As String = "Sheet3"
Const dstFirst As String = "A2" ' do not change the 'A' (entire row).
Const pLen As Long = 5
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Source Range.
Dim LastRow As Long
Dim srg As Range
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1)
End With
' 'Combine' critical cells into a range.
Dim brg As Range ' Built Range
Dim cel As Range ' Current Cell Range
For Each cel In srg.Cells
If Len(cel.Value) > pLen Then
If brg Is Nothing Then
Set brg = cel
Else
Set brg = Union(brg, cel)
End If
End If
Next cel
If brg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
' Copy and delete critical rows of Source Range.
With wb.Worksheets(dstName).Range(dstFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count).Clear
Set brg = brg.EntireRow ' 'Convert' cells into rows.
brg.Copy .Offset ' Copy. 'Offset' because range is in 'With'.
brg.Delete ' Delete.
End With
Application.ScreenUpdating = False
End Sub

Answer 3

Text the next code, please. It uses arrays and it should be very fast for a big range:
Sub testSplitZiPCodeStrings()
Dim sh2 As Worksheet, sh3 As Worksheet, lastR As Long
Dim i As Long, arr, arrZip, arrNoZip, kZ As Long, kN As Long
Set sh2 = ActiveSheet ' Worksheets("Sheet2")
Set sh3 = sh2.Next ' Worksheets("Sheet3")
lastR = sh2.Range("D" & sh2.Rows.count).End(xlUp).row 'last row
arr = sh2.Range("D2:D" & lastR).Value 'put the range in an array
ReDim arrZip(UBound(arr) - 1) 'redim the array to surely have place for all elements
ReDim arrNoZip(UBound(arr) - 1) 'redim the array to surely have place for all elements
For i = 1 To UBound(arr) ' iterate between the array elements
If Len(arr(i, 1)) = 5 Then
arrZip(kZ) = arr(i, 1): kZ = kZ + 1
Else
arrNoZip(kN) = arr(i, 1): kN = kN + 1
End If
Next i
ReDim Preserve arrZip(kZ - 1) 'keep only the array elements having values
ReDim Preserve arrZip(kN - 1) 'keep only the array elements having values
sh2.Range("D2:D" & lastR).Clear 'Clear the initial range
'Drop the Zip array content at once:
sh2.Range("D2").Resize(UBound(arrZip), 1).Value = Application.Transpose(arrZip)
'Drop the NoZip array content at once:
sh3.Range("D2").Resize(UBound(arrNoZip), 1).Value = Application.Transpose(arrNoZip)
End Sub

Answer 4

Here's 2 samples. The first one is more intuitive and uses ranges. The second one is less intuitive but faster by using arrays.
Simple but Slower:
'The easy way, but can be slow if you have lots of zip codes
Sub TrimRange()
Dim InputWorksheet As Worksheet, OutputWorksheet As Worksheet
Dim RangeInput As Range, RangeOutput As Range, Column As Range
Dim HeaderRow As Integer, ColumnNumber As Integer, LastRow As Integer, i As Integer
Dim OutputColumn As Range
Dim ColumnFound As Boolean
Dim fullzipcode As String
Set InputWorksheet = Worksheets("Sheet2")
Set OutputWorksheet = Worksheets("Sheet3")
HeaderRow = 1
'Get Input and Output Range
ColumnNumber = 0
ColumnFound = False
For Each Column In InputWorksheet.Columns
ColumnNumber = ColumnNumber + 1
If Column.Cells(HeaderRow, 1) = "postalcode" Then
LastRow = Column.End(xlDown).Row
'I assume the Output column will be in the same position as the input column
Set OutputColumn = OutputWorksheet.Columns(ColumnNumber)
'If OutputColumn is always in Column 'D' then replace previous line with:
'Set OutputColumn = OutputWorksheet.Columns(4)
Set RangeInput = InputWorksheet.Range(Column.Cells(HeaderRow + 1, 1), Column.Cells(LastRow, 1))
Set RangeOutput = OutputWorksheet.Range(OutputColumn.Cells(HeaderRow + 1, 1), OutputColumn.Cells(LastRow, 1))
ColumnFound = True
Exit For
End If
Next
If ColumnFound Then
'Initialize Interior color to nothing
'and remove values from output column
RangeInput.Interior.ColorIndex = 0
RangeOutput.ClearContents
'Change values and formatting
For i = 1 To RangeInput.Rows.Count
fullzipcode = RangeInput.Cells(i, 1).Value
If Len(fullzipcode) > 5 Then
RangeInput.Cells(i, 1).Interior.Color = RGB(255, 0, 0)
RangeInput.Cells(i, 1).Value = Left(fullzipcode, 5)
End If
RangeOutput.Cells(i, 1).Value = fullzipcode
Next
End If
End Sub
Faster but Less Intuitive
'The harder way, but faster
Sub TrimRange2()
Dim InputWorksheet As Worksheet, OutputWorksheet As Worksheet
Dim RangeInput As Range, RangeOutput As Range, Column As Range
Dim HeaderRow As Integer, ColumnNumber As Integer, LastRow As Integer, i As Integer
Dim InputValues() As Variant, OutputValues() As Variant
Dim OutputColumn As Range
Dim ColumnFound As Boolean
Dim fullzipcode As String
Set InputWorksheet = Worksheets("Sheet2")
Set OutputWorksheet = Worksheets("Sheet3")
HeaderRow = 1
'Get Input and Output Range
ColumnNumber = 0
ColumnFound = False
For Each Column In InputWorksheet.Columns
ColumnNumber = ColumnNumber + 1
If Column.Cells(HeaderRow, 1) = "postalcode" Then
LastRow = Column.End(xlDown).Row
'I assume the Output column will be in the same position as the input column
Set OutputColumn = OutputWorksheet.Columns(ColumnNumber)
'If OutputColumn is always in Column 'D' then replace previous line with:
'Set OutputColumn = OutputWorksheet.Columns(4)
Set RangeInput = InputWorksheet.Range(Column.Cells(HeaderRow + 1, 1), Column.Cells(LastRow, 1))
Set RangeOutput = OutputWorksheet.Range(OutputColumn.Cells(HeaderRow + 1, 1), OutputColumn.Cells(LastRow, 1))
ColumnFound = True
Exit For
End If
Next
If ColumnFound Then
'Initialize Interior color to nothing
'and remove values from output column
RangeInput.Interior.ColorIndex = 0
RangeOutput.ClearContents
'Initialize Arrays (much faster than working with ranges)
InputValues = RangeInput.Value2
OutputValues = RangeOutput.Value2
'Change values and formatting
For i = 1 To RangeInput.Rows.Count
fullzipcode = InputValues(i, 1)
If Len(fullzipcode) > 5 Then
RangeInput.Cells(i, 1).Interior.Color = RGB(255, 0, 0)
InputValues(i, 1) = Left(fullzipcode, 5)
End If
OutputValues(i, 1) = fullzipcode
Next
'Save arrays to ranges
RangeInput.Value2 = InputValues
RangeOutput.Value2 = OutputValues
End If
End Sub