如何用VBA在Excel中筛选含两个3和两个7的五位数？

原代码无法得到正确结果的核心问题有几点：

• 错误使用Left函数：Left(cell, n)是取前n个字符，而非第n位字符，导致无法正确统计每一位的3和7；
• 循环范围错误：需求是处理第一列（A列）的10000-65000五位数，原代码遍历的范围完全不符合；
• 逻辑判断缺失：未检查7的数量是否为2，仅判断3的数量大于1，不符合需求；
• 冗余变量：fourCount定义后未使用，属于无效代码。

以下提供两种符合需求的实现方案：

方案一：逐位数值取数（无字符串操作） #

通过数值运算提取每一位数字，避免字符串转换可能带来的格式问题：

Sub FindNumbersWithTwo3AndTwo7()
    Dim cell As Range
    Dim num As Long
    Dim digit As Integer
    Dim threeCount As Integer, sevenCount As Integer
    
    ' 遍历A列中符合范围的单元格，遇空停止
    For Each cell In Range("A:A")
        If cell.Value >= 10000 And cell.Value <= 65000 Then
            num = cell.Value
            threeCount = 0
            sevenCount = 0
            
            ' 逐位提取数字并统计3和7的数量
            Do While num > 0
                digit = num Mod 10
                If digit = 3 Then
                    threeCount = threeCount + 1
                ElseIf digit = 7 Then
                    sevenCount = sevenCount + 1
                End If
                num = num \ 10 ' 移除最后一位
            Loop
            
            ' 严格匹配需求：恰好2个3和2个7（五位数剩余一位非3非7）
            If threeCount = 2 And sevenCount = 2 Then
                Debug.Print cell.Value ' 输出到VBA立即窗口
                ' 可选：标记符合条件的单元格
                ' cell.Interior.Color = RGB(255, 255, 0)
            End If
        ElseIf cell.Value = "" Then
            Exit For ' 空单元格停止遍历，提升效率
        End If
    Next cell
End Sub

方案二：正确的字符串处理方式 #

如果偏好字符串操作，使用Mid函数正确提取每一位字符，逻辑更直观：

Sub FindNumbersWithTwo3AndTwo7_String()
    Dim cell As Range
    Dim numStr As String
    Dim i As Integer
    Dim threeCount As Integer, sevenCount As Integer
    
    For Each cell In Range("A:A")
        If cell.Value >= 10000 And cell.Value <= 65000 Then
            numStr = CStr(cell.Value)
            threeCount = 0
            sevenCount = 0
            
            ' 遍历五位数的每一位（索引1到5）
            For i = 1 To 5
                Select Case Mid(numStr, i, 1)
                    Case "3"
                        threeCount = threeCount + 1
                    Case "7"
                        sevenCount = sevenCount + 1
                End Select
            Next i
            
            If threeCount = 2 And sevenCount = 2 Then
                Debug.Print cell.Value
                ' 可选：复制结果到其他工作表
                ' cell.Copy Destination:=Sheets("结果").Range("A" & Rows.Count).End(xlUp).Offset(1)
            End If
        ElseIf cell.Value = "" Then
            Exit For
        End If
    Next cell
End Sub

关键说明 #

• 遍历优化：仅处理A列中10000-65000的数值，遇到空单元格立即停止，避免遍历整个列的无效运算；
• 条件严谨：严格判断threeCount=2和sevenCount=2，确保符合“包含两个3和两个7”的需求；
• 可扩展性：代码中注释了标记单元格、复制结果的可选操作，可根据实际需求调整。

内容的提问来源于stack exchange，提问作者jeromekjerome