多层领导审查同意的名单

summerlcb · 发表于 2017-3-19 10:12

如附件所示，要求名单同时通过表格1及表格1的要求，显示在表格3.
拜托老师了，谢谢

summerlcb · 发表于 2017-3-19 15:10

求老师帮帮忙，谢谢

jiminyanyan · 发表于 2017-3-19 16:06

Sub jimin()
Dim arr, d As Object, brr(1 To 10000, 1 To 1), crr, m
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("b3:g" & Sheet1.Range("b65535").End(xlUp).Row)
For i = 1 To UBound(arr)
If arr(i, 6) = "√" Then
d(arr(i, 1)) = d(arr(i, 1)) + 1
End If
Next
arr = Sheet2.Range("b3:e" & Sheet1.Range("b65535").End(xlUp).Row)
For i = 1 To UBound(arr)
If arr(i, 4) = "√" Then
d(arr(i, 1)) = d(arr(i, 1)) + 1
End If
Next
crr = d.keys
For i = 0 To UBound(crr)
If d(crr(i)) = 2 Then
m = m + 1
brr(m, 1) = crr(i)
End If
Next
Sheet3.Range("b3:b10000").ClearContents
Sheet3.Range("b3").Resize(UBound(brr), 1) = brr
End Sub

复制代码

jiminyanyan · 发表于 2017-3-19 16:08

………………

yaozong · 发表于 2017-3-19 16:33

Sub test()
Dim d, arr, brr, i&, j&, k&, m&, n&
Set d = CreateObject("Scripting.Dictionary")
arr = Sheet1.Range("b3:g" & Sheet1.[b3].End(4).Row)
brr = Sheet2.Range("b3:e" & Sheet2.[b3].End(4).Row)
ReDim crr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
  If arr(i, 6) = "√" Then
d(arr(i, 1)) = ""
  End If
Next
For i = 1 To UBound(brr)
  If brr(i, 4) = "√" Then
If d.exists(brr(i, 1)) Then
   m = m + 1
   crr(m, 1) = brr(i, 1)
   crr(m, 2) = "√"
End If
  End If
Next
With Sheet3.[b3]
  .Resize(1000, 2).ClearContents
  .Resize(m, 2) = crr
End With
Set d = Nothing
End Sub

yaozong · 发表于 2017-3-19 16:35

参考附件

170319-多层领导签字通过的名单.rar (15.54 KB, 下载次数: 12)

jiminyanyan · 发表于 2017-3-19 16:44

这种题手工最快，数据透视表一两分钟解决

summerlcb · 发表于 2017-3-19 17:14

jiminyanyan 发表于 2017-3-19 16:06

老师您好，这里明明判断的数据在第7列，您这为什么用If arr(i, 6) = "√" Then

jiminyanyan · 发表于 2017-3-19 19:47

summerlcb 发表于 2017-3-19 17:14
老师您好，这里明明判断的数据在第7列，您这为什么用If arr(i, 6) = "√" Then

arr = Sheet1.Range("b3:g" & Sheet1.[b3].End(4).Row)
A列没装入数组…………。

		自动登录	找回密码
密码			免费注册

[求助] 多层领导审查同意的名单

评分