Public Sub s_1()
    key & "='关键字'" '获取关键字行
    For i = 0 To UBound(arr, 2)
        On Error Resume Next
        Set sht = wbk.Sheets(arr(0, i)) '检查是否已经存在关键字分表
        If Err.Number <> 0 Then Set sht = wbk.Worksheets.Add '若不存在则添加关键字分表
        With sht
            .Cells.Clear
            .Name = arr(0, i)
            sql = Replace(sqlx, "关键字", arr(0, i)) '构造关键字查询语句
            Set rs = cnn.Execute(sql)
            .[1:1] = rng.Rows(1).Value '写入分表表头
            .[a2].CopyFromRecordset rs '写入分s表数据
        End With
    Next
End Sub

Public Sub 拆分()
    拆分SHEET Sheet1.UsedRange, "姓名"
End Sub