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 iEnd FunctionPublic 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 IfEnd FunctionPrivate 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 tidxEnd FunctionPrivate 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    NextEnd FunctionPrivate 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 IfEnd FunctionPrivate 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 = resultEnd FunctionPublic 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 rEnd FunctionPrivate 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 FunctionPublic 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 rEnd FunctionPrivate 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 IfEnd FunctionPublic 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 IfEnd FunctionPrivate 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 IfEnd FunctionPrivate 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 IfEnd 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 IfEnd Sub</p><p> </p>

 

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