提取姓名中含有指定字符的人员信息

APPLE123

提取姓名中含有指定字符的人员信息

1、在表1中B列查找姓名中第一个字为“陈”，且最后一个字为“亮”的姓名，“陈”与“亮”中间是什么字符无所谓，并将符合此条件的姓名行的相关信息（序号、姓名、证号、项目F）在表2输出，结果详见表2。
2、本例仅为部分数据，实例数据较多，有几千条数据。
3、个别人员姓名有4个字符，甚至5个字符。
希望VBA一键获取。
请老师们帮忙看看，谢谢！

今铭昔

ynzsvt

直接高级筛选录制即可

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, i&, j&, r&
   
    r = Cells(Rows.Count, "A").End(xlUp).Row
   
    ar = Range("A4:G" & r).Value: r = 1
    ar(1, 4) = ar(1, 6)
    With CreateObject("VBScript.RegExp")
        .Pattern = "^陈.*亮"
        For i = 2 To UBound(ar)
            If .test(ar(i, 2)) Then
                r = r + 1: ar(r, 1) = r - 1
                For j = 2 To 3
                    ar(r, j) = ar(i, j)
                Next j
                ar(r, 4) = ar(i, 6)
            End If
        Next i
    End With
   
    [P1].Resize(r, 4) = ar
    Beep
End Sub

gwjkkkkk

请参考图片。。。

taller

1. Sub DEMO()
   
2.     Dim conn As Object, rst As Object, strSQL$, i&, PathStr$, sht As Worksheet
   
3.     Set conn = CreateObject("ADODB.Connection")
   
4.     Set rst = CreateObject("ADODB.Recordset")
   
5.     PathStr = ThisWorkbook.FullName                                     '路径
   
6.     Select Case Application.Version * 1
   
7.         Case Is <= 11
   
8.             conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & PathStr & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=0'"
   
9.         Case Is >= 12
   
10.             conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=0'"
    
11.     End Select
    
12.     Dim oSht As Worksheet: Set oSht = ActiveSheet ' modify as needed
    
13.     Dim lastRow As Long: lastRow = oSht.Cells(oSht.Rows.Count, "A").End(xlUp).Row
    
14.    
    
15.     strSQL = "SELECT 序号,姓名,证号,项目F FROM [" & oSht.Name & "$A4:G" & lastRow & "] where 姓名 like '陈%亮'"
    
16.     rst.Open strSQL, conn, 1, 1
    
17.     Set sht = Worksheets.Add(ActiveSheet)
    
18.     With sht
    
19.         For i = 0 To rst.Fields.Count - 1
    
20.             .Cells(1, i + 1) = rst.Fields(i).Name
    
21.         Next i
    
22.         .Range("a2").CopyFromRecordset rst
    
23.     End With
    
24.     rst.Close:    conn.Close:    Set conn = Nothing:    Set rst = Nothing
    
25. End Sub

复制代码

zhangcheng6688

借楼学习一下正则
Sub test()
arr = Sheet1.[a1].CurrentRegion
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "^陈.*亮$"
ReDim brr(1 To UBound(arr), 1 To 4)
For i = 5 To UBound(arr)
   If reg.test(arr(i, 2)) Then
      m = m + 1
      For j = 1 To 3
         brr(m, j) = arr(i, j)
      Next
      brr(m, 4) = arr(i, 6)
   End If
Next
Sheet2.[a1].CurrentRegion.Offset(1).ClearContents
If m > 0 Then
   Sheet2.[a2].Resize(m, 4) = brr
End If
End Sub

3190496160

Private Sub CommandButton1_Click()
Dim ar As Variant
Dim i As Long, r As Long
Dim br()
ks = TextBox1.Text
js = TextBox2.Text
If ks = "" And js = "" Then MsgBox "您至少要输入一个查询条件！": Exit Sub
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 5 Then MsgBox "数据源为空！": End
    ar = .Range("a4:g" & r)
End With
ReDim br(1 To UBound(ar), 1 To 4)
For i = 2 To UBound(ar)
    s = ar(i, 2)
    If s <> "" Then
        s_2 = Right(s, 1)
        s_1 = Left(s, 1)
        If ks <> "" And js <> "" Then
            If s_1 = ks And s_2 = js Then
                n = n + 1
                For j = 1 To 3
                    br(n, j) = ar(i, j)
                Next j
                br(n, 4) = ar(i, 6)
            End If
        ElseIf ks <> "" And js = "" Then
            If s_1 = ks Then
                n = n + 1
                For j = 1 To 3
                    br(n, j) = ar(i, j)
                Next j
                br(n, 4) = ar(i, 6)
            End If
        ElseIf ks = "" And js <> "" Then
            If s_2 = js Then
                n = n + 1
                For j = 1 To 3
                    br(n, j) = ar(i, j)
                Next j
                br(n, 4) = ar(i, 6)
            End If
        End If
    End If
Next i
If n = "" Then MsgBox "没有符合条件的数据！": Exit Sub
With Sheets("sheet2")
    .[a1].CurrentRegion.Offset(1).Borders.LineStyle = 0
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(n, UBound(br, 2)) = br
    .[a2].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
    .Activate
End With
MsgBox "查询到" & n & "行数据！", 64, "提醒！"
Unload Me
End Sub

3190496160

提取姓名中含有指定字符的人员信息.rar (27.88 KB, 下载次数: 16)

2025-4-6 10:39 上传

点击文件名下载附件

3190496160

利用窗体，可以自由输入查询条件，可以只输入一个条件，也可以输入两个条件查询