判断条件，并将符合的输出到另一张表

nedelux

如下图，判断第一个表(All表)的B列单元格的第一个字符，将对应的单元格输入到对应的其它表中；
“T表”里只显示 T1043和T0043，依次类推！谢谢各位。
（注：这个是不是只能用函数实现）

捞屎人

凑合着可以实现你的功能  懒得写了

nedelux

捞屎人 发表于 2022-11-22 18:40
凑合着可以实现你的功能  懒得写了

这个看起来好复杂啊，不过还是谢谢！

gwjkkkkk

Sub TEST()
    Dim arr, i&, dic As Object, vKey, wks As Worksheet
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    arr = [B1].CurrentRegion
    For i = 2 To UBound(arr)
      vKey = Mid(arr(i, 1), 1, 1)
      If Not dic.exists(vKey) Then
         Set dic(vKey) = CreateObject("Scripting.Dictionary")
      End If
      dic(vKey)(arr(i, 1)) = ""
    Next i
    For Each vKey In dic.keys
       If bIsWorksheetExist(CStr(vKey)) Then
          With Worksheets(vKey)
             .[A1].CurrentRegion.Cells.Clear
             .[A1] = "号码"
             .[A2].Resize(dic(vKey).Count) = Application.Transpose(dic(vKey).keys)
          End With
       End If
    Next
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub
Public Function bIsWorksheetExist(wksName As String) As Boolean
    On Error Resume Next
    bIsWorksheetExist = Sheets(wksName).Name = wksName
End Function

gwjkkkkk

代码审核中，请参考附件。。。

nedelux

gwjkkkkk 发表于 2022-11-22 19:13
代码审核中，请参考附件。。。

确实可以实现，有点小问题，覆盖了标题字段

xiaomi123ok

gwjkkkkk 发表于 2022-11-22 19:13
代码审核中，请参考附件。。。

Set dic(vKey) = CreateObject("Scripting.Dictionary")
dic(vKey)(arr(i, 1)) = ""
字典嵌套，学习了，但是“嵌套”的字典，在“本地窗口”中不显示！
明白了，谢谢老师！

gwjkkkkk

搜索字典嵌套。。。

打字比你快

如果数据量不大，用SQL+for也可以。

Dim con As Object, sql$
    Dim i, ii
    Dim rng As Range
   
    Sheets("T").Cells.ClearContents
    Sheets("S").Cells.ClearContents
    Sheets("M").Cells.ClearContents
   
    Sheets("T").[a1] = "号码"
    Sheets("S").[a1] = "号码"
    Sheets("M").[a1] = "号码"

    Set con = CreateObject("adodb.connection")
    con.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.FullName

    Set rng = Sheets("ALL").Range("A" & Rows.Count).End(xlUp)

    For i = 2 To rng.Row

        ii = VBA.Mid(Sheets("ALL").Range("a" & i), 1, 1)
     
        sql = "select 号码 from [ALL$] where 号码 like '" & ii & "%'"
        
        On Error Resume Next
            If Not Sheets(ii) Is Nothing Then                       '判断工作表是否存在
              Set rng = Sheets(ii).Range("A" & Rows.Count).End(xlUp)
              Sheets(ii).Range("A" & rng.Row + 1).CopyFromRecordset con.Execute(sql)
            End If

    Next i
   
    Sheets("T").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    Sheets("S").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    Sheets("M").Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
    con.Close: Set con = Nothing