设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求VBA按条件筛选分类问题急需！！！！！！！
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2199|回复: 3

[已解决]求VBA按条件筛选分类问题急需！！！！！！！

[复制链接]
发表于 2016-2-20 13:37 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 下雨dê天 于 2016-3-5 18:43 编辑

我们公司属于制造型企业，每天都有很多员工入职，员工会按分配组上，主任；领导要求每天做一份报表按主任 ，组长将员工分类号，求大神帮忙设计一下公式；该表格每天都要交到领导审核，非常急 求帮忙解决！
最佳答案
月排行榜 / 总排行榜
grf1973
2016-3-7 14:01
  1. Sub 匹配()
  2.     arr = Sheet1.[a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)  '读入数据并分类
  5.         zr = arr(i, 15)    '主任
  6.         zz = arr(i, 14)    '组长
  7.         zw = arr(i, 10)   '职位
  8.         xm = arr(i, 2)   '姓名
  9.         bm = arr(i, 16)   '部门
  10.         If Len(zr) > 0 And Len(zz) > 0 Then
  11.             If InStr(d(zr), zz) = 0 Then d(zr) = d(zr) & "," & zz
  12.         End If
  13.         If Len(zz) > 0 Then
  14.             x = zz & zw
  15.             If zw = "半烫" Or zw = "装篮工" Or zw = "组长助理" Then
  16.                 d(x) = xm
  17.             ElseIf zw = "车工" Then
  18.                 d(zz) = d(zz) & "," & xm
  19.             End If
  20.         End If
  21.         xx = ""
  22.         If zw = "飞机位" Then xx = zw
  23.         If bm = "裁床组" Or bm = "后道组" Then xx = Left(bm, 2)
  24.         If zw = "车工" And Len(zz) = 0 Then xx = "未分组"
  25.         If Len(xx) > 0 Then d(xx) = d(xx) & "," & xm
  26.     Next
  27.     With Sheet2
  28.         .[c3:be21] = ""
  29.         For c = 3 To 43 Step 10
  30.             zr = .Cells(2, c)
  31.             If d.exists(zr) Then
  32.                 xrr = Split(Mid(d(zr), 2), ",")
  33.                 .Cells(3, c).Resize(1, UBound(xrr) + 1) = xrr     '填入组长
  34.             End If
  35.         Next
  36.         brr = .Range("a1:be21")
  37.         For c = 3 To 52
  38.             zz = .Cells(3, c) '组长
  39.             For i = 4 To 6            '填入组长对应的半烫、装篮工、组长助理
  40.                 x = zz & .Cells(i, 2)
  41.                 .Cells(4, c) = d(x)
  42.             Next
  43.             If d.exists(zz) Then      '填入组长对应的车工
  44.                 xrr = Split(Mid(d(zz), 2), ",")
  45.                 .Cells(5, c).Resize(UBound(xrr) + 1, 1) = Application.Transpose(xrr)
  46.             End If
  47.         Next
  48.         For c = 53 To 56         '填入飞机位、未分组、裁床、后道
  49.             xx = .Cells(2, c)
  50.             If d.exists(xx) Then
  51.                 xrr = Split(Mid(d(xx), 2), ",")
  52.                 .Cells(3, c).Resize(UBound(xrr) + 1, 1) = Application.Transpose(xrr)
  53.             End If
  54.         Next
  55.     End With
  56. End Sub
复制代码
要求.png
要求2.jpg

求助（急需）.zip

555.58 KB, 下载次数: 6

sasa
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2016-3-5 18:43 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
=INDEX($B:$B,SMALL(IF(($F$2:$F$1377=$L3)*($G$2:$G$1377=M$2),ROW($A$2:$A$1377),65536),COUNTIF($L$3:$L3,$L3)))&""
回复

使用道具 举报

QCW911
发表于 2016-3-7 11:05 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
有偿编写，有意加QQ 57726980
回复

使用道具 举报

grf1973
发表于 2016-3-7 14:01 | 显示全部楼层    本楼为最佳答案   
  1. Sub 匹配()
  2.     arr = Sheet1.[a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)  '读入数据并分类
  5.         zr = arr(i, 15)    '主任
  6.         zz = arr(i, 14)    '组长
  7.         zw = arr(i, 10)   '职位
  8.         xm = arr(i, 2)   '姓名
  9.         bm = arr(i, 16)   '部门
  10.         If Len(zr) > 0 And Len(zz) > 0 Then
  11.             If InStr(d(zr), zz) = 0 Then d(zr) = d(zr) & "," & zz
  12.         End If
  13.         If Len(zz) > 0 Then
  14.             x = zz & zw
  15.             If zw = "半烫" Or zw = "装篮工" Or zw = "组长助理" Then
  16.                 d(x) = xm
  17.             ElseIf zw = "车工" Then
  18.                 d(zz) = d(zz) & "," & xm
  19.             End If
  20.         End If
  21.         xx = ""
  22.         If zw = "飞机位" Then xx = zw
  23.         If bm = "裁床组" Or bm = "后道组" Then xx = Left(bm, 2)
  24.         If zw = "车工" And Len(zz) = 0 Then xx = "未分组"
  25.         If Len(xx) > 0 Then d(xx) = d(xx) & "," & xm
  26.     Next
  27.     With Sheet2
  28.         .[c3:be21] = ""
  29.         For c = 3 To 43 Step 10
  30.             zr = .Cells(2, c)
  31.             If d.exists(zr) Then
  32.                 xrr = Split(Mid(d(zr), 2), ",")
  33.                 .Cells(3, c).Resize(1, UBound(xrr) + 1) = xrr     '填入组长
  34.             End If
  35.         Next
  36.         brr = .Range("a1:be21")
  37.         For c = 3 To 52
  38.             zz = .Cells(3, c) '组长
  39.             For i = 4 To 6            '填入组长对应的半烫、装篮工、组长助理
  40.                 x = zz & .Cells(i, 2)
  41.                 .Cells(4, c) = d(x)
  42.             Next
  43.             If d.exists(zz) Then      '填入组长对应的车工
  44.                 xrr = Split(Mid(d(zz), 2), ",")
  45.                 .Cells(5, c).Resize(UBound(xrr) + 1, 1) = Application.Transpose(xrr)
  46.             End If
  47.         Next
  48.         For c = 53 To 56         '填入飞机位、未分组、裁床、后道
  49.             xx = .Cells(2, c)
  50.             If d.exists(xx) Then
  51.                 xrr = Split(Mid(d(xx), 2), ",")
  52.                 .Cells(3, c).Resize(UBound(xrr) + 1, 1) = Application.Transpose(xrr)
  53.             End If
  54.         Next
  55.     End With
  56. End Sub
复制代码

求助（急需）.rar

200.29 KB, 下载次数: 10
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-19 08:59 , Processed in 0.327372 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表