【AutoMarkTool】Private Sub如何放入Module使用

本文链接：https://blog.csdn.net/u011410413/article/details/46455301

需求：在日常audit时候，判断完数据问题以后，还要根据不同数据问题选择不同defect type。现希望只要判断数据问题，在选择defect type环节降低错误率和劳动成本。

因为毕竟判断数据问题才是关键，这块是主要价值，手动选择defect type是个繁琐的小动作虽然对于结果是必要的，但是价值的根本不在它，它只是价值体现。面对大量数据的时候，选择defect type会有一定小概率的出错可能。

其实就此功能是很好实现的，有意思的地方在于当一个工作薄有多个sheet的时候触发事件sheet_change只能作用在sheet上，比如我有5个sheet都要通过sheet_change事件触发这个功能，难道每次都去粘贴五遍代码去各个sheet，这不科学。经过摸索，我发现了一篇有用的文章：http://www.cpearson.com/excel/Events.aspx

根据这篇文章，我把这个需求基本完善了。

首先在module里面定义一个Collection 对象。Collection会把一组相关项目视为单一对象引用。添加就用add，消除某个组员就用remove。

Public WSColl As Collection

接着插入一个class moduel模块，更改名称为CWorksheetObject

接下来就在class module里面写下以下代码，这里的亮点就是withevents，它会把事件体系和WS这个变量连接住。从而让你可以使用WS_Change。高级！

Public WithEvents WS As Worksheet

Private Sub WS_Change(ByVal Target As Range)
 
'*Shutdown Screen update for running efficiency;¹ØµôÆÁÄ»¸üÐÂ£¬Ê¹³ÌÐòÔË×ª¼Ó¿ì¡£
Application.ScreenUpdating = False

'This is to prevent disturbance when auditor need modify the sheet; µ±Auditor³¢ÊÔ´ó·¶Î§ÐÞ¸Ä¸ñÊ½»ò±à¼Êý¾ÝÊ±£¬ÕâÊÇÓÃÀ´·ÀÖ¹Ìø³öerror message
On Error GoTo Error_handler

    


    '*First confirming the changing value is under source value column; Ê×ÏÈÈ·¶¨¸ü¸Äµ¥Ôª¸ñÎ»ÓÚSource Valueµ×ÏÂ¡£
    If Cells(1, Target.Column).Value = "Source Value" Then
    
 
    
    
        '*If Source Value = EXOI Value, the data point is free from defect; ÈôSource Value µÈÓÚEXOI Value£¬ÄÇÃ´½á¹ûÎªFree¡£
        If Target.Value = Cells(Target.Row, Target.Column - 1).Value Then
                Cells(Target.Row, Target.Column + 1).Value = "Free"
                '* All kinds of situation ¸÷ÖÖÀàÐÍµÄÅÐ·¨
                ElseIf Target.Value <> Cells(Target.Row, Target.Column - 1).Value Then
                    
                    If Target.Value = "N/A" Then
                        Cells(Target.Row, Target.Column + 1).Value = "FC"
                        
                    ElseIf Cells(Target.Row, Target.Column - 1).Value = 0 Or Cells(Target.Row, Target.Column - 1).Value = "NULL" Then
                        
                           Cells(Target.Row, Target.Column + 1).Value = "D-C"
                           
                    ElseIf Target.Value = "NULL" Then '*It must be added here, otherwise error msg pops out; ×¢Òâ´Ë¾ä±ØÐë¼Ó£¬²»È»µ½ÏÂÃæÕâ¾äelseifÄÇÀïÕâ¸öÇé¿ö¾Í»á±äbug
                            Cells(Target.Row, Target.Column + 1).Value = "D-A"
                    
                    ElseIf WorksheetFunction.Round(Cells(Target.Row, Target.Column - 1).Value, 2) = WorksheetFunction.Round(Target.Value, 2) Then
                            
                        Cells(Target.Row, Target.Column + 1).Value = "Free"
                        Cells(Target.Row, Target.Column + 1).Font.Color = RGB(255, 0, 0)
                       
                        
                    Else:
                        Cells(Target.Row, Target.Column + 1).Value = "D-A"
                    
                    End If
                                     
                    
        End If
                                      
        
    End If
    

    
Error_handler:
Exit Sub

End Sub

最后回到module，写下一个function:

Sub TestProc()
        Dim WSObj As CWorksheetObject
        Dim WSheet As Worksheet

        If WSColl Is Nothing Then
            Set WSColl = New Collection
        End If
        
        Set WSObj = New CWorksheetObject
        Set WSheet = ActiveSheet
        WSheet.Name = ActiveSheet.Name
        Set WSObj.WS = WSheet
On Error GoTo Error_Dismiss
        WSColl.Add Item:=WSObj, Key:=WSheet.Name
Error_Dismiss:
Exit Sub
       

  
End Sub

到此代码部分就结束了。以后要在工作薄任意的sheet里运行针对sheet_change的那个事件，只要“呼唤”一下module里面的这个TestProc。TestProc就会去呼唤WS_Change实现事件了。

Remove的语句这个程序不涉及，但是还是放一个范例。不用vb格式了，不然中文变乱码

For Num = 1 To MyClasses.Count 。
MyClasses.Remove 1 ' 因为每删除一个对象后，集合
' 会自动重排顺序，故每次迭代时只需删除第一个
Next Num ' 对象即可。