提取部门最大工号

SCWYZJ

求助：这次希望有老师帮我实现这两个效果，不胜感激！奉送小花以表谢意！因为上次我参照网上的方法修改的不是理想，时而可以，时而不行！（第二个效果），所以这次在这再次请教一下各位老师，谢谢！

duquancai

那两个效果？看不了附件。

182197315

Sub 提取最大工号()
Dim i%, arr
Dim d As New Dictionary
arr = Range("A4:G" & Cells(Cells.Rows.Count, 1).End(xlUp).Row)
For i = 2 To UBound(arr)
    If d(arr(i, 4)) < arr(i, 1) Then d(arr(i, 4)) = arr(i, 1)
Next
Range("A2") = d(Range("D2").Value)
End Sub

活在理想的世界

这个应该做出全自动的，按钮都不用点，输入名称直接给出新的最大工号。

tudarong

182197315 发表于 2018-6-30 20:12
Sub 提取最大工号()
Dim i%, arr
Dim d As New Dictionary

代码中采用了前期绑定字典，有些用户是无法打开的，
我才用了后期绑定的方式。
楼主希望能直接显示 自动A2条件区填充本部门的最新最大工号，稍微改动了下。

1. Sub 提取最大工号()
   
2. 
   
3. Dim i%, arr
   
4. Dim d As Object
   
5. Dim m As Integer
   
6. 
   
7. Set d = CreateObject("scripting.dictionary")
   
8. m = Cells(Cells.Rows.Count, 1).End(xlUp).Row
   
9. 
   
10. arr = Range("A4:G" & m)
    
11.     For i = 2 To UBound(arr)
    
12.         If d(arr(i, 4)) < arr(i, 1) Then d(arr(i, 4)) = arr(i, 1)
    
13.     Next
    
14. Range("A2") = d(Range("D2").Value) + 1
    
15. 
    
16. End Sub

复制代码

tudarong

提取部门最大编号.rar (22.09 KB, 下载次数: 11)

2018-6-30 20:34 上传

点击文件名下载附件

excelvlookup

Sub aa() '按一级部门提最大工号
rw = Sheet1.Cells(Rows.Count, 1).End(3).Row
yjbm = Sheet1.Range("d2")
If yjbm = "" Then
    MsgBox "请填写一级部门"
    Exit Sub
End If
    gh = 0
For i = 5 To rw
    If Sheet1.Cells(i, 4) = yjbm Then
        If Int(Sheet1.Cells(i, 1)) > gh Then
            gh = Int(Sheet1.Cells(i, 1))
        End If
    End If
Next
Sheet1.Cells(2, 1) = gh + 1
End Sub
Sub bb() '前三后三
rw = Sheet2.Cells(Rows.Count, 1).End(3).Row
ar = Sheet2.Range("a3:c" & rw)
ReDim br(1 To UBound(ar))
For i = 1 To UBound(ar)
    a = ar(i, 3)
    br(a) = br(a) & "," & i
Next
For j = 3 To 1 Step -1
    b = Split(br(j), ",")
    For k = 1 To UBound(b)
        n = n + 1
        Sheet2.Cells(n + 9, 5) = ar(Int(b(k)), 1)
        Sheet2.Cells(n + 9, 6) = ar(Int(b(k)), 2)
        Sheet2.Cells(n + 9, 7) = ar(Int(b(k)), 3)
    Next
Next
r = 0: s = 0: n = 0
While r < 3
    t = UBound(br) - s
    If br(t) <> "" Then
        b = Split(br(t), ",")
        For k = 1 To UBound(b)
            n = n + 1
            Sheet2.Cells(n + 9, 9) = ar(Int(b(k)), 1)
            Sheet2.Cells(n + 9, 10) = ar(Int(b(k)), 2)
            Sheet2.Cells(n + 9, 11) = ar(Int(b(k)), 3)
        Next
        r = r + 1
    End If
    s = s + 1
Wend
End Sub

excelvlookup

前三后三，为了效对，从第10行开始写的

活在理想的世界

tudarong 发表于 2018-6-30 20:34
代码中采用了前期绑定字典，有些用户是无法打开的，
我才用了后期绑定的方式。
楼主希望能直接显示 自 ...

我看过你的问题，这段代码如果是工号打乱顺序的话会匹配错误的。

duquancai

只做“效果2”：提取最前三名！！！，提取最后三名 原理一样，自己做！！！

1. Sub main()
   
2.     Dim conn As Object, sql$, s$
   
3.     Sheets("效果2").Select: Range("E3:G100").ClearContents
   
4.     Set conn = CreateObject("adodb.connection")
   
5.     conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & ThisWorkbook.FullName
   
6.     s = "select top 3 f3 from [效果2$A3:C] where f3 is not null group by f3"
   
7.     sql = "select b.f1,b.f2,a.f3 from (" & s & ") a left join [效果2$A3:C] b on a.f3=b.f3 order by a.f3 desc"
   
8.     Range("e3").CopyFromRecordset conn.Execute(sql)
   
9. End Sub

复制代码