Excel 检测单元格中超过5个字符的宏（邮政编码）

我创建了一个基于列名检索范围的函数。这是我的密码：

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

表2输入栏D 表2输出列D 表3输出列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

---

编辑我误解了你的问题，我更新了我的答案，以便与你的问题联系起来

这里有一个基本的方法可以满足你的要求。它跳过了第一排

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

如果符合条件，则复制整行

选项显式
副邮递员15（）
'定义常量。
Const srcName As String=“Sheet2”
Const srcFirst As String=“D2”
常量dstName为String=“Sheet3”
Const dstFirst As String=“A2”'不更改“A”（整行）。
当长度=5时，保持正压
'定义工作簿。
将wb设置为工作簿：设置wb=ThisWorkbook包含此代码的工作簿。
'定义源范围。
最后一排一样长
变暗srg As范围
使用wb.Worksheets（srcName）.Range（srcFirst）
LastRow=.Offset（.Worksheet.Rows.Count-.Row）.End（xlUp）.Row
设置srg=.Resize（LastRow-.Row+1）
以
将关键单元格“”合并到一个范围中。
变暗brg作为“内置范围”
Dim cel As范围“当前单元格范围”
对于srg.cell中的每个cel
如果Len（cel.Value）>pLen，则
如果brg不算什么，那么
设置brg=cel
其他的
设置brg=接头（brg，cel）
如果结束
如果结束
下一个细胞
如果brg为空，则退出Sub
Application.ScreenUpdating=False
'复制和删除源范围的关键行。
使用wb.Worksheets（dstName）.Range（dstFirst）
.Resize（.Worksheet.Rows.Count-.Row+1_
.工作表.列.计数）。清除
Set brg=brg.EntireRow“”将单元格转换为行。
brg.Copy.Offset“Copy”“偏移量”，因为范围在“带”。
brg.Delete“删除”。
以
Application.ScreenUpdating=False
端接头

请输入下一个代码。它使用阵列，在大范围内速度应该非常快：

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

---

这里有两个样品。第一个更直观，并且使用范围。第二种方法不太直观，但使用数组更快

简单但速度较慢：

'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

速度更快但不太直观

'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

---

问题是什么？所以我有公司名称、市州和邮政编码。我需要一个宏，如果邮政编码超过5个字符（如上所示），则该宏将整行移动到另一张工作表。

我需要一个宏，如果邮政编码超过5个字符（如上所示），则该宏将整行移动到另一张工作表。

如图所示使用自动筛选。使用

标准1:=“=？？？*”

。这比循环快得多。你能添加注释来了解它的功能吗？我是VBA的初学者。这很有帮助，但是我想把整行剪切粘贴到另一张工作表（Sheet3）中，然后在上面使用你的代码。非常感谢。这是我正在使用的数据示例。公司名称城市州代码postalcode RWJ大学医院Somerset Somerville NJ 08876I清理代码效率稍低，但可能更有意义？让我知道有什么不清楚的地方。它给了我编译错误：ByRef参数类型不匹配旧代码工作得很好。我只想将20k数据中邮政编码超过5的整行移动到单独的工作表中，然后运行代码在5个邮政编码之后删除，这样我可以在运行宏后检查所有邮政编码是否正确。感谢您的帮助和时间，我将重新发布我的旧代码。您没有指定要打开文件，因此在提出新请求之前，您应该

接受这里发布的几个高质量答案中的一个。如果不这样做，您的问题将更多地出现在“做我的工作”与网站针对特定代码的故障排除方面。这是你的第一篇帖子，所以没什么大不了的（我的更糟）。只需选择一个能提高您知识水平的答案（最好是我的答案，但VBasic很酷），然后单击
接受
，然后继续做下去，如果您仍然无法回答，请发布另一个具体问题。祝你好运。如果我先运行了你的代码，然后@PGSystemTester给了我想要的最终结果，那就非常感谢你。我是初学者，你能给我解释一下你为什么使用Const吗。我知道迪姆。您还可以解释“复制和删除源范围的关键行”中的调整大小和偏移。非常感谢你，你可以<代码>范围（“A2”）

与

范围（“A2”）.偏移（0，0）

或短

范围（“A2”）.偏移相同。因为我的范围在
With
语句中，我不想写
brg.Copy wb.Worksheets（dstName）.range（dstFirst）
，所以我只使用
.Offset
。
调整大小
部分在工作表上创建从单元格到最后一个单元格的范围（
A2:XFD1048576
），在这种情况下，意味着除第一行中的单元格外，每个单元格都将被清除。你能分享一下我的代码有什么问题吗？这样我就可以改进了。太好了，谢谢你。我只是想了解它的所有部分。我感谢你的帮助。非常感谢。