用VBA检测各机构录入数据是否符合标准

sohoxs

请教各位老师，能帮忙用VBA做个检测各机构录入数据是否符合标准的监测表么？谢谢了！

补充内容 (2016-7-27 22:08):
已解决，多谢zax010老师的帮助，谢谢！

wep2010

检测各机构录入数据是否符合标准；
是一线员工在输入的时候检测；还是上交到你的手中，你进行检测？

zhouxiao

好像用函数就可以啊

zax010

Sub zz()
    Dim d, ar, br
    Set d = CreateObject("Scripting.Dictionary")
    ar = Range("A1:H" & [a65536].End(3).Row)
    For i = 2 To UBound(ar)
        If ar(i, 2) <> "" And Len(ar(i, 3)) = 11 And Len(ar(i, 6)) = 18 And _
            (ar(i, 5) = "A" Or ar(i, 5) = "AA" Or ar(i, 5) = "AAA") Then
        ar(i, 8) = 1
    Else
        ar(i, 8) = 0
    End If
Next
ReDim br(1 To UBound(ar), 1 To 6)
For i = 2 To UBound(ar)
    s = ar(i, 4)
    If d(s) = "" Then
        m = m + 1: d(s) = m: br(m, 1) = s
        If ar(i, 2) <> "" Then br(m, 2) = 1
        If Len(ar(i, 3)) = 11 Then br(m, 3) = 1
        If ar(i, 5) = "A" Or ar(i, 5) = "AA" Or ar(i, 5) = "AAA" Then br(m, 4) = 1
        If Len(ar(i, 6)) = 18 Then br(m, 5) = 1
        If ar(i, 8) = 1 Then br(m, 6) = 1
    Else
        If ar(i, 2) <> "" Then br(d(s), 2) = br(d(s), 2) + 1
        If Len(ar(i, 3)) = 11 Then br(d(s), 3) = br(d(s), 3) + 1
        If ar(i, 5) = "A" Or ar(i, 5) = "AA" Or ar(i, 5) = "AAA" Then br(d(s), 4) = br(d(s), 4) + 1
        If Len(ar(i, 6)) = 18 Then br(d(s), 5) = br(d(s), 5) + 1
        If ar(i, 8) = 1 Then br(d(s), 6) = br(d(s), 6) + 1
    End If
Next
Sheet2.[a3].Resize(m, 6) = br
[h1].Resize(UBound(ar)) = Application.Index(ar, 0, 8)
End Sub

zax010

>>>>>>>>>>>>>>>>>>>>>>>>


用VBA检测各机构录入数据是否符合标准.rar (18.74 KB, 下载次数: 40)

2016-7-24 17:23 上传

点击文件名下载附件

sohoxs

zax010 发表于 2016-7-24 17:24
>>>>>>>>>>>>>>>>>>>>>>>>

非常感谢老师的回复，刚测试已没问题，谢谢！能否再抽空帮忙完善下，因我现在还得加上公式才行，能不能用VBA一次完成。现在的操作过程是这样的：我每天从系统中导出表格，手工筛选后再COPY到老师您这表中才行，如果能只须从系统中导出直接COPY到这表中就能完成会非常省力省时间了，再次拜托老师了，万分感谢！（注：第一次发的时候怕太复杂了，没老师帮忙，不好意思!)

sohoxs

zhouxiao 发表于 2016-7-24 16:14
好像用函数就可以啊

数据量大，机构有30多家，现在要每天监测，目前就是用公式加筛选的方法，看论坛上各们老师们用VBA很方便，就想着试一下。

sohoxs

wep2010 发表于 2016-7-24 16:02
检测各机构录入数据是否符合标准；
是一线员工在输入的时候检测；还是上交到你的手中，你进行检测？

我从系统中导出一线员工录入的数据进行监测，因机构多数据量大，监测不符合要求的好让他们重新录入过。谢谢！

jiminyanyan

做个记号。。。。

lsc900707

留个脚印看结果>>>>>>>>>