Excel VBA：数据管理与维护

最近做了一个使用Excel VBA管理库存数据的小练习。附代码：

 

Public Function WorksheetActivate(ByVal Cancel As Boolean)
    'This function is defined to add new line to sheet2, and it can only be used in sheet3-18
    If Cancel Then
        Exit Function
    End If
    
    Dim r, c, i, rr, key As Long
    Dim flag As Boolean
    Dim dump As Integer
    
    r = ActiveSheet.UsedRange.Rows.Count
    c = ActiveSheet.UsedRange.Columns.Count
    dump = 0
    For i = 2 To r
        
        flag = True
        For j = 2 To c
            If ActiveSheet.Cells(i, j).text <> "" Then
                flag = False
                Exit For
            End If
        Next j
        If flag Then
            dump = dump + 1
        Else
            dump = 0
        End If
        
        If ActiveSheet.Cells(i, 1).text = "" Then
            For j = 2 To c
                If ActiveSheet.Cells(i, j).text <> "" Then
                    newLine ActiveSheet.Index, i, 2
                    Exit For
                End If
            Next j
        End If
        
        If dump > 20 Then
            MsgBox "Error occurs 3.", vbOKOnly, "Alarm"
            Exit For
        End If
    Next i
End Function

Public Function Worksheet2Activate()
    Dim r, rn, mn, ibl As Long
    Dim key As String
    mn = 0
    rn = ActiveSheet.UsedRange.Rows.Count
    For r = 2 To rn
        If ActiveSheet.Cells(r, 1).Font.Bold = False Or ActiveSheet.Cells(r, 1).Interior.ColorIndex = 0 Then
            mn = r - 1
            Exit For
        End If
    Next r
    If mn = 0 Then
        mn = rn
    End If
    If mn < 10 And mn <> rn Then
        Application.ScreenUpdating = False
        For r = 2 To mn
            key = ActiveSheet.Cells(r, 1).text
            If key = "" Then
                MsgBox "Error occurs 0.", vbOKOnly, "Error"
            Else
                ibl = getInsertBeforeLoc(2, key, mn + 1, rn)
                ActiveSheet.Rows(ibl).Insert shift:=xlDown
                ActiveSheet.Rows(r).Copy ActiveSheet.Cells(ibl, 1)
            End If
        Next r
        If mn - 1 > 2 Then
            ActiveSheet.Rows("2:" + Trim(Str(mn))).Delete shift:=xlUp
        End If
        Application.ScreenUpdating = True
    Else
        ActiveSheet.Columns("A:" + num2Snum(ActiveSheet.UsedRange.Columns.Count)).Sort _
        key1:=Range("A1:A" + Trim(Str(rn))), order1:=xlAscending, Header:=xlYes
    End If
End Function

Private Function newLine(ByVal idx As Integer, ByVal row As Long, ByVal tidx As Integer)
    Dim key, ibf As Long
    Dim skey As String
    key = getKeyNum(idx) + 1
    skey = ActiveSheet.Name + "_" + Str(key)
    ibf = 2
    Sheets(tidx).Rows(ibf).Insert shift:=xlDown
    Sheets(idx).Cells(row, 1).Value = key
    Sheets(idx).Rows(row).Copy Sheets(tidx).Cells(ibf, 1)
    Sheets(tidx).Cells(ibf, 1).Value = skey
    Sheets(tidx).Range("A" & ibf, num2Snum(Sheets(tidx).UsedRange.Columns.Count) & ibf).Interior.ColorIndex = 5
    Sheets(tidx).Range("A" & ibf, num2Snum(Sheets(tidx).UsedRange.Columns.Count) & ibf).Font.Bold = True
    delHyperlinks tidx
End Function

Private Function delHyperlinks(ByVal tidx As Integer)
    Dim flag As Boolean
    flag = False
    For Each hl In Sheets(tidx).UsedRange.Hyperlinks
        If Not flag Then
            flag = True
        Else
            hl.Delete
        End If
    Next
End Function
Private Function getInsertBeforeLoc(ByVal idx As Integer, ByVal skey As String, ByVal fidx As Long, ByVal eidx As Long) As Long
    Dim midx As Long, text As String
    midx = (fidx + eidx) / 2
    text = Sheets(idx).Cells(midx, 1).text
    If text = "" Or fidx > eidx Then
        getInsertBeforeLoc = fidx
    Else
        If text < skey Then
            getInsertBeforeLoc = getInsertBeforeLoc(idx, skey, midx + 1, eidx)
        ElseIf text > skey Then
            getInsertBeforeLoc = getInsertBeforeLoc(idx, skey, fidx, midx - 1)
        Else
            MsgBox "Error occurs 1.", vbOKOnly, "Error"
        End If
    End If
End Function

Private Function getKeyNum(ByVal idx As Integer) As Long
    Dim r, i, temp, result As Long
    
    r = Sheets(idx).UsedRange.Rows.Count
    result = 0
    For i = r To 2 Step -1
            temp = Sheets(idx).Cells(i, 1).Value
            If temp <> "" And result < temp Then
                result = temp
            End If
    Next i
    getKeyNum = result
End Function

Public Function WorksheetDeactivate()
    'This function is defined to delete those empty rows
    Dim r, c, rn, cn, key, temp, damn As Long
    Dim hasValue As Boolean
    Dim skey As String
    damn = 0
    rn = ActiveSheet.UsedRange.Rows.Count
    cn = ActiveSheet.UsedRange.Columns.Count
    For r = 2 To rn
        If ActiveSheet.Cells(r, 1).text <> "" Then
            hasValue = False
            For c = 2 To cn
                If ActiveSheet.Cells(r, c).text <> "" Then
                    hasValue = True
                    Exit For
                End If
            Next c
            If Not hasValue Then
                If IsNumeric(ActiveSheet.Cells(r, 1).text) Then
                    damn = damn + 1
                    key = ActiveSheet.Cells(r, 1).text
                    skey = ActiveSheet.Name + "_" + Str(key)
                    ActiveSheet.Rows(r).Delete shift:=xlUp
                    temp = find(2, skey)
                    If temp <> 0 Then
                        Sheet2.Rows(temp).Delete shift:=xlUp
                    End If
                End If
            Else
                damn = 0
            End If
        Else
            ActiveSheet.Rows(r).Delete shift:=xlUp
        End If
        If damn > 20 Then
            MsgBox "Error occurs 3.", vbOKOnly, "Alarm"
            Exit For
        End If
    Next r
End Function

Private Function find(ByVal idx As Integer, ByVal skey As String) As Long
    Dim r, rn, mn As Long
    rn = Sheets(idx).UsedRange.Rows.Count
    For r = 2 To rn
        If Sheets(idx).Cells(r, 1).Font.Bold Then
            If Sheets(idx).Cells(r, 1).text = skey Then
                find = r
                Exit Function
            End If
        Else
            mn = r
            Exit For
        End If
    Next r
    find = dichotomy(idx, skey, mn, rn)
End Function

Public Function WorksheetChange(ByVal Target As Range)
    Dim r, c, tr, key As Long
    Dim skey As String
    Dim hasValue As Boolean
    If Target.Column = 1 Then
        Exit Function
    End If
    For r = Target.row To (Target.row + Target.Rows.Count - 1)
        If ActiveSheet.Cells(r, 1).text = "" And r > 1 Then
            hasValue = False
            For c = 2 To ActiveSheet.UsedRange.Columns.Count
                If ActiveSheet.Cells(r, c).text <> "" Then
                    hasValue = True
                    Exit For
                End If
            Next c
            If hasValue Then
                newLine ActiveSheet.Index, r, 2
            End If
        ElseIf IsNumeric(ActiveSheet.Cells(r, 1).text) Then
            key = ActiveSheet.Cells(r, 1).text
            skey = ActiveSheet.Name + "_" + Str(key)
            tr = find(2, skey)
            If tr <> 0 Then
                For c = Target.Column To (Target.Column + Target.Columns.Count - 1)
                    Sheet2.Cells(tr, c).Value = ActiveSheet.Cells(r, c).text
                    Sheet2.Cells(tr, c).Interior.ColorIndex = 5
                    Sheet2.Cells(tr, c).Font.Bold = True
                    Sheet2.Cells(tr, 1).Interior.ColorIndex = 5
                    Sheet2.Cells(tr, 1).Font.Bold = True
                Next c
                Sheet2.Rows(2).Insert shift:=xlDown
                Sheet2.Rows(tr + 1).Copy Sheet2.Cells(2, 1)
                Sheet2.Rows(tr + 1).Delete shift:=xlUp
            End If
        End If
    Next r
End Function

Private Function dichotomy(ByVal sidx As Integer, ByVal key As String, ByVal fidx As Long, ByVal eidx As Long) As Long
    Dim midx As Long, text As String
    midx = (fidx + eidx) / 2
    text = Sheets(sidx).Cells(midx, 1).text
    If fidx >= eidx And text <> key Then
        dichotomy = 0
    Else
        If text = key Then
            dichotomy = midx
        ElseIf text < key Then
            dichotomy = dichotomy(sidx, key, midx + 1, eidx)
        Else
            dichotomy = dichotomy(sidx, key, fidx, midx - 1)
        End If
    End If
End Function

Public Function WorksheetSelectionChange(ByVal Target As Range)
    If Target.Worksheet.Index = ActiveSheet.Index And Target.Column = 1 Then
            If Target.row > 1 Or Target.Rows.Count > 1 Then
                ActiveSheet.Range(num2Snum(Target.Column + 1) & _
                Target.row, num2Snum(Target.Column + Target.Columns.Count - 1) _
                & (Target.row + Target.Rows.Count - 1)).Select
            End If
     End If
End Function

Private Function StateMachinery(ByVal ok As Boolean, ByVal idx As Integer)
    Dim r, rr, c, cc As Long
    If ok Then
        rr = Sheets(idx).UsedRange.Rows.Count
        For r = 1 To rr
            If Sheets(idx).Cells(r, 1).Font.Bold Then
                Sheets(idx).Rows(r).Font.Bold = False
            End If
            If Sheets(idx).Cells(r, 1).Interior.ColorIndex <> 0 Then
                Sheets(idx).Range("A" & r, num2Snum(Sheets(idx).UsedRange.Columns.Count) & r).Interior.ColorIndex = 0
            End If
        Next r
    End If
End Function

Private Function num2Snum(ByVal c As Long) As String
    Alphas = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", _
    "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
    If c > 26 Then
        num2Snum = num2Snum((c - 1) / 26) + Alphas((c - 1) Mod 26)
    Else
        num2Snum = Alphas((c - 1) Mod 26)
    End If
End Function


<p>Public Sub MarkRead()
    'StateMachinery True, 2
    Dim sresult As String
    sresult = InputBox("Please input your password:", "Password")
    If sresult = "xiexiaoyan" Then
        Worksheet2Activate
        StateMachinery True, 2
        ActiveSheet.Rows(1).Select
    End If
End Sub</p><p>
 </p>

 

代码的主要目的是维持汇总表单和各分表单数据的一致性，并将分表的新建数据及更新数据显示在汇总表的顶端。