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

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

So I have companyname-City-state and postal code. I need a macro that will move the entire row to another sheet if the zip code have more than 5 characters as shown above — Jake8281, Jan 26 '21 at 17:27
`I need a macro that will move the entire row to another sheet if the zip code have more than 5 characters as shown above ` Use Autofilter as shown [HERE](https://stackoverflow.com/questions/11631363/how-to-copy-a-line-in-excel-using-a-specific-word-and-pasting-to-another-excel-s). Use `Criteria1:="=?????*"`. This is much faster than looping. — Siddharth Rout, Jan 26 '21 at 19:09

pgSystemTester · Accepted Answer · 2021-01-26T19:57:46.320

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

edited Jan 26 '21 at 19:57

answered Jan 26 '21 at 17:27

pgSystemTester

8,979
2
23
49

Can you add comments to know what it does, I am beginner in VBA. This helpful But I want to cut and paste the whole row into another worksheet(Sheet3) then use ur above code on them. Thank you. This is a sample of data am working with. company_name city statecode postalcode RWJ University Hospital Somerset Somerville NJ 08876 – Jake8281 Jan 26 '21 at 17:34
I cleaned up the code to be a little less effecient but probably makes a bit more sense? Let me know what isn't clear. – pgSystemTester Jan 26 '21 at 17:40
Its giving me Compile error: ByRef argument type mismatch – Jake8281 Jan 26 '21 at 17:51
The old code works perfectly. I just want to move the whole row that have zip code from than 5 out of the 20k Data into separate sheet then run your code the remove after 5 zip codes so I can check if all the zip codes are correct after I run the macro. Thank you for your help and time – Jake8281 Jan 26 '21 at 17:56
I will repost my old code. You made no specification of wanting to open a file, so you should be `accepting` one of the several quality answers posted here before making new requests. Without doing so, your questions appear more along the lines of "do my work" vs. what the site is geared towards of troubleshooting specific code. It's your first post, so no big deal (mine was worse). Just pick an answer that improved your knowledge (preferably mine but VBasic is cool) and click `accept`, then work on it, and post another specific question if you're still stuck. Good luck. – pgSystemTester Jan 26 '21 at 19:53
I included a couple lines of code so you could see how to use my code for different sheets and different files. You can download the file I used by clicking here: https://1drv.ms/x/s!AiO7_3PtXmZ9g4E6KtyQ0W3rybPIFQ?e=8AYFW7 – pgSystemTester Jan 26 '21 at 19:59
I appreciate your time and help. Thank you – Jake8281 Jan 27 '21 at 07:07
Great... but you should still `accept` someone's answer. – pgSystemTester Jan 27 '21 at 17:19
I chose yours already I clicked on the upper arrow. Is that right ? – Jake8281 Jan 28 '21 at 00:10
Where can I find it ? – Jake8281 Jan 29 '21 at 04:21

VBasic2008 · Answer 2 · 2021-01-26T18:38:07.137

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

Thank you a lot your code if I ran first then @PGSystemTester after gives me the end result I wanted. I am beginner so can you explain to me why did you use Const . I know Dim. and also can you explain resize and offset in ' Copy and delete critical rows of Source Range. Thank you a lot — Jake8281, Jan 26 '21 at 22:49
You can [google constants](https://www.google.com/search?q=vba+Using+constants&oq=vba+Using+constants). `Range("A2")` is the same as `Range("A2").Offset(0, 0)` or short `Range("A2").Offset`. Since I have my range in a `With` statement and I don't want to write `brg.Copy wb.Worksheets(dstName).Range(dstFirst)`, I'm using just `.Offset`. The `Resize` part creates a range from the cell to the last cell (`A2:XFD1048576`) on the worksheet in this case meaning every cell will be cleared except the cells in the first row. Could you share what is wrong with my code so I can improve? — VBasic2008, Jan 26 '21 at 23:40
Nothing wrong with it. Its perfect thank you . I was just trying to understand all the parts of it. I appreciate your help. Thank you — Jake8281, Jan 27 '21 at 07:09

score 0 · Answer 3 · answered Jan 26 '21 at 18:36

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

score 0 · Answer 4 · answered Jan 26 '21 at 19:15

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

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

4 Answers4

Copy Entire Rows If Criteria Met