Excel vba 写的一个宏，很久没用了，备份一下，备查

Sub 水电费统计()

    AllTest
    
    Dim roomNum As String   '宿舍号
    Dim name As String  '姓名
    Dim waterUsed As String '水 实用 分表
    Dim waterFree As String '水 保底
    Dim eleUsed As String   '电 实用 分表
    Dim eleFree As String   '电 保底
    Dim waterAvg As String  '水 超出数量
    Dim eleAvg As String    '电 超出数量
    Dim waterTotal As String '水 总表 实用
    Dim eleTotal As String '电 总表 实用
    
    
    Dim arr(0) As Integer
    
    roomNum = "宿舍号"
    name = "姓名"
    waterUsed = "水 分表 实用"
    waterFree = "水 保底"
    eleUsed = "电 分表 实用"
    eleFree = "电 保底"
    waterAvg = "水 超出数量"
    eleAvg = "电 超出数量"
    waterTotal = "水 总表 实用"
    eleTotal = "电 总表 实用"
    
    'MsgBox Range("q7").MergeArea.Cells(1).Address
    'MsgBox getAllValue(5, 32, 11)
    'MsgBox isContained("1234", "1 3")
    '得到宿舍号所在的单元格
    roomNumCell = getCell(roomNum)
    If (isValidCellStr(roomNumCell)) Then
        For i = getCellRow(roomNumCell) + 1 To getMaxRow()
            tmpCell = getCellName(i, getCellCol(roomNumCell))
            If (isValidCellStr(tmpCell) And getCellValue(tmpCell) = "") Then
                roomNumCell = tmpCell
            Else
                Exit For
            End If
        Next i
    Else
        MsgBox "没有找到'宿舍号'所在的单元格！"
        Exit Sub
    End If
    
    'MsgBox getCellColExt(getCellRow(roomNumCell), eleTotal)
    '查找其他单元格
    row = getCellRow(roomNumCell)
    
    roomCol = getCellCol(roomNumCell)
    
    nameCol = getCellColExt(row, "姓名")
    If (nameCol < 1) Then
        MsgBox "没有找到'姓名'所在的单元格"
        Exit Sub
    End If
    
    waterUsedCol = getCellColExt(row, "水 分表 实用")
    If (waterUsedCol < 1) Then
        waterUsedCol = getCellColExt(row, "水 实用")
        If (waterUsedCol < 1) Then
            MsgBox "没有找到'水 分表 实用'所在的单元格"
            Exit Sub
        End If
    End If
    
    eleUsedCol = getCellColExt(row, "电 分表 实用")
    If (eleUsedCol < 1) Then
        eleUsedCol = getCellColExt(row, "电 实用")
        If (eleUsedCol < 1) Then
            MsgBox "没有找到'电 分表 实用'所在的单元格"
            Exit Sub
        End If
    End If
    
    waterOverCol = getCellColExt(row, "水 超出数量")
    If (waterOverCol < 1) Then
        MsgBox "没有找到'水 超出数量'所在的单元格"
        Exit Sub
    End If
    
    eleOverCol = getCellColExt(row, "电 超出数量")
    If (eleOverCol < 1) Then
        MsgBox "没有找到'电 超出数量'所在的单元格"
        Exit Sub
    End If
    
    warningMsg = ""
    waterTotalCol = getCellColExt(row, "水 总表 实用")
    If (waterTotalCol < 1) Then
        warningMsg = warningMsg & "没有找到'水 总表 实用'所在的单元格" & Chr(13) & Chr(10)
    End If
    
    eleTotalCol = getCellColExt(row, "电 总表 实用")
    If (eleTotalCol < 1) Then
        warningMsg = warningMsg & "没有找到'电 总表 实用'所在的单元格" & Chr(13) & Chr(10)
    End If
    
    waterBaseCol = getCellColExt(row, "水 保底")
    If (waterBaseCol < 1) Then
        warningMsg = warningMsg & "没有找到'水 保底'所在的单元格" & Chr(13) & Chr(10)
    End If
    
    eleBaseCol = getCellColExt(row, "电 保底")
    If (eleBaseCol < 1) Then
        warningMsg = warningMsg & "没有找到'电 保底'所在的单元格" & Chr(13) & Chr(10)
    End If
    
    waterAvgCol = getCellColExt(row, "水 公摊")
    If (waterAvgCol < 1) Then
        warningMsg = warningMsg & "没有找到'水 公摊'所在的单元格" & Chr(13) & Chr(10)
    End If
    
    eleAvgCol = getCellColExt(row, "电 公摊")
    If (eleAvgCol < 1) Then
        warningMsg = warningMsg & "没有找到'电 公摊'所在的单元格" & Chr(13) & Chr(10)
    End If
    
    If (Len(warningMsg) > 0) Then
        MsgBox "警告：" & Chr(13) & Chr(10) & warningMsg
    End If
    
    'MsgBox getAllValue(row + 1, getMaxRow(), waterUsedCol)
    
    '非空宿舍数量
    roomCount = 0
    For iRow = row + 1 To getMaxRow()
        If Not (ActiveSheet.Cells(iRow, roomCol).Value = "") Then
            For iiRow = iRow To iRow + ActiveSheet.Cells(iRow, roomCol).MergeArea.Cells.Count - 1
                If (ActiveSheet.Cells(iiRow, nameCol) <> "") Then
                    roomCount = roomCount + 1
                    Exit For
                End If
            Next iiRow
        End If
    Next iRow
    
    '超出的水量
    waterOverTotal = 0
    If (waterTotalCol > 0) Then
        waterOverTotal = getFirstValue(row + 1, getMaxRow(), waterTotalCol) - getAllValue(row + 1, getMaxRow(), waterUsedCol)
        If (waterOverTotal < 0) Then
            waterOverTotal = 0
        End If
    End If
    
    '超出的电量
    eleOverTotal = 0
    If (eleTotalCol > 0) Then
        eleOverTotal = getFirstValue(row + 1, getMaxRow(), eleTotalCol) - getAllValue(row + 1, getMaxRow(), eleUsedCol)
        If (eleOverTotal < 0) Then
            eleOverTotal = 0
        End If
    End If
    
    
    '开始赋值
    For iRow = row + 1 To getMaxRow()
        
        
        tmpCell = getCellName(iRow, roomCol)
        If Not (getCellValue(tmpCell) = "") Then
            
            ''统计人数
            personCnt = 0
            For iiRow = iRow To iRow + getRoomSize(tmpCell) - 1
            
                '清除原来的值
                ActiveSheet.Cells(iiRow, waterOverCol).Value = ""
                ActiveSheet.Cells(iiRow, eleOverCol).Value = ""
                If (waterAvgCol > 0) Then ActiveSheet.Cells(iiRow, waterAvgCol).Value = ""
                If (eleAvgCol > 0) Then ActiveSheet.Cells(iiRow, eleAvgCol).Value = ""
                
                If Not (ActiveSheet.Cells(iiRow, nameCol) = "") Then
                    personCnt = personCnt + 1
                End If
            Next iiRow
            
            If (personCnt > 0) Then
            
                '实际使用的水量和电量
                waterUsed = getFirstValue(iRow, row + 1, waterUsedCol) + waterOverTotal / roomCount - getFirstValue(iRow, row + 1, waterBaseCol)
                If (waterUsed < 0) Then waterUsed = 0
                
                eleUsed = getFirstValue(iRow, row + 1, eleUsedCol) + eleOverTotal / roomCount - getFirstValue(iRow, row + 1, eleBaseCol)
                If (eleUsed < 0) Then eleUsed = 0
                
                
                '是否是合并项
                If (ActiveSheet.Cells(iRow, waterOverCol).MergeCells) Then
                    ActiveSheet.Cells(iRow, waterOverCol).Value = waterUsed
                    ActiveSheet.Cells(iRow, eleOverCol).Value = eleUsed
                    If (waterAvgCol > 0) Then
                        ActiveSheet.Cells(iRow, waterAvgCol).Value = waterOverTotal / roomCount
                    End If
                    If (eleAvgCol > 0) Then
                        ActiveSheet.Cells(iRow, eleAvgCol).Value = eleOverTotal / roomCount
                    End If
                Else
                    For iiRow = iRow To iRow + personCnt - 1
                        ActiveSheet.Cells(iiRow, waterOverCol).Value = waterUsed / personCnt
                        ActiveSheet.Cells(iiRow, eleOverCol).Value = eleUsed / personCnt
                    Next iiRow
                End If
            End If
        End If
    Next iRow
    
    

End Sub

Function getCellColExt(ByVal row As Integer, ByVal str As String) As Integer
    '在row行查找符合字符str的单元格的列坐标
    For iCol = 1 To getMaxCol()
        cellValue = getExtCellValue(getCellName(row, iCol))
        If (isContained(cellValue, str)) Then
            getCellColExt = iCol
            Exit Function
        End If
    Next iCol

    getCellColExt = -1
End Function

Function getAllValue(ByVal rowStart As Integer, ByVal rowEnd As Integer, ByVal col As Integer) As Double
    '返回行rowStart->rowEnd，列为col的单元格的和
On Error GoTo ErrorHandlerForGetAllValue
    Dim nStep As Integer
    If (rowStart > rowEnd) Then
        nStep = -1
    Else
        nStep = 1
    End If
    
    colSum = 0
    For iRow = rowStart To rowEnd Step nStep
        cellValue = ActiveSheet.Cells(iRow, col).Value
        If isNumber(cellValue) Then
            colSum = colSum + Val(cellValue)
        End If
    Next iRow
    
    getAllValue = colSum
    Exit Function
ErrorHandlerForGetAllValue:
    getAllValue = 0
End Function

Function getFirstValue(ByVal rowStart As Integer, ByVal rowEnd As Integer, ByVal col As Integer) As Double
    '返回行rowStart->rowEnd，列为col的单元格中，第一个值不为空的单元格
On Error GoTo ErrorHandlerForGetFirstValue
    Dim nStep As Integer
    If (rowStart > rowEnd) Then
        nStep = -1
    Else
        nStep = 1
    End If
    
    For iRow = rowStart To rowEnd Step nStep
        cellValue = ActiveSheet.Cells(iRow, col).Value
        If Not (cellValue = "") Then
            getFirstValue = Val(cellValue)
            Exit For
        End If
    Next iRow
    
    Exit Function
ErrorHandlerForGetFirstValue:
    getFirstValue = 0
End Function

Function getRoomSize(ByVal roomCell As String) As Integer
    '房间大小
    row = getCellRow(roomCell)
    col = getCellCol(roomCell)
    
    getRoomSize = ActiveSheet.Cells(row, col).MergeArea.Cells.Count
End Function



'弹出一个输入窗口，输入一个单元格
'promtMsg 输入窗口的提示信息
'title 输入窗口的标题
Function getCellStr(desc As String) As String
    Dim inputStr As String
    Dim errorMsg As String  '错误信息
    
    Do
    
        inputStr = InputBox(errorMsg & "请输入" & desc & "所在的单元格（如A1）：", "输入" & desc) '输入宿舍号
        
        If (inputStr = "" And StrPtr(inputStr) = 0) Then Exit Do  '点击取消按钮，退出
            
        If (isValidCellStr(inputStr)) Then      '验证单元格是否有效
            getCellStr = inputStr    '给返回值赋值
            Exit Do
        Else
            errorMsg = "'" & roomTitleCell & "'不是一个有效的单元格，" & Chr(13) & Chr(10)  '错误信息
        End If
        
    Loop

End Function





'=====================================================================================
'=====================================================================================
'=======================*********以下是通用函数************===========================
'=====================================================================================
'=====================================================================================

Function AllTest()
    '通用函数的测试

    '测试isValidCellStr函数
    If Not (isValidCellStr("az12345") And Not isValidCellStr("aaa") And Not isValidCellStr("12345") And Not isValidCellStr("")) Then
        MsgBox ("isValidCellStr函数错误，请检查")
    End If

    '测试getLetterIndex函数
    If Not (getLetterIndex("a") = 1 And getLetterIndex("A") = 1 And getLetterIndex("z") = 26 And getLetterIndex("") = -1) Then
        MsgBox ("getLetterIndex 函数错误，请检查！")
        Exit Function
    End If
    
    '测试isLetter函数
    If Not (isLetter("abc") And Not isLetter("abc123")) Then
        MsgBox ("isLetter函数错误，请检查！")
    End If
    
    '测试isNumber函数
    If Not (isNumber("123") And Not isNumber("123abc")) Then
        MsgBox ("isNumber函数错误，请检查！")
    End If
    
    '测试getLetterStringLeft函数
    If Not (getLetterStringLeft("abc123") = "abc" And getLetterStringLeft("123abc") = "") Then
        MsgBox ("getLetterStringLeft函数错误，请检查！")
    End If
    
    '测试getNumberStringRight函数
    If Not (getNumberStringRight("abc123") = "123" And getNumberStringRight("123abc") = "") Then
        MsgBox ("getNumberStringRight函数错误，请检查！")
    End If
    
    '测试getCellRow函数
    If Not (getCellRow("A11") = 11 And getCellRow("AA") = -1) Then
        MsgBox ("getCellRow函数错误，请检查！")
    End If
    
    '测试getCellCol函数
    If Not (getCellCol("Aa1") = 27 And getCellCol("AA") = -1) Then
        MsgBox ("getCellCol函数错误，请检查！")
    End If
    
    '测试getLetter函数
    If Not (getLetter(1) = "A" And getLetter(26) = "Z" And getLetter(123) = "") Then
        MsgBox ("getLetter函数错误，请检查！")
    End If
    
    '测试getCellName函数
    If Not (getCellName(1, 1) = "A1" And getCellName(5, 52) = "AZ5" And getCellName(0, 1) = "") Then
        MsgBox ("getCellName函数错误，请检查！")
    End If
    
    '测试isContained函数
    If Not (isContained("实用电（总表）", "电 总表 实用") And Not isContained("abcdef g", "a fg")) Then
        MsgBox ("isContained函数错误，请检查！")
    End If

End Function

Function isContained(ByVal searchedStr As String, ByVal keyStr As String) As Boolean
    '判断searchedStr是否包含有关键字keyStr
    'keyStr可以有多个关键字，用空格隔开" "
    splitArr = Split(keyStr, " ")
    isContained = True
    For i = 0 To UBound(splitArr)
        If (InStr(searchedStr, splitArr(i)) <= 0) Then
            isContained = False
            Exit For
        End If
    Next i

    
End Function

Function getMaxCol() As Integer
    '返回当前工作簿最大的列号
    getMaxCol = ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column - 1
End Function

Function getMaxRow() As Integer
    '返回当前工作簿最大的行号
    getMaxRow = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.row - 1
End Function

Function getCell(ByVal searchStr As String) As String
    '在工作簿中搜索字符串，主要搜索标题，支持最多两行标题，关键字用空格分开
    Dim iRow As Integer
    Dim iCol As Integer
    
    For iRow = 1 To ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.row - 1
        For iCol = 1 To ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column - 1
            If (InStr(ActiveSheet.Cells(iRow, iCol).Value, searchStr) > 0) Then
                getCell = getCellName(iRow, iCol)
                Exit Function
            End If
        Next iCol
    Next iRow
    getCell = ""
End Function

Function getCellIntVal(ByVal row As Integer, ByVal col As Integer) As Double
    '返回单元格的数值，如果单元格不为数值，返回0
On Error GoTo ErrorHandlerForGetCellIntVal

    getCellValue = Val(ActiveSheet.Cells(row, col).Value)
    Exit Function
    
ErrorHandlerForGetCellIntVal:
    getCellIntVal = 0
End Function

Function getCellValue(ByVal cellStr As String) As String
    '获取单元格的内容
On Error GoTo ErrorHandlerForGetCellValue
    If (isValidCellStr(cellStr)) Then
        getCellValue = ActiveSheet.Cells(getCellRow(cellStr), getCellCol(cellStr)).Value
    Else
        getCellValue = ""
    End If
    
    Exit Function
ErrorHandlerForGetCellValue:
    getCellValue = ""
End Function

Function getExtCellValue(ByVal cellStr As String) As String
    '获取单元格的内容+单元格上一列的内容
On Error GoTo ErrorHandlerForGetExtCellValue
    
    Dim tmpStr As String    '单元格上一行最近（列要小于cellStr，且内容不为空）的单元格内容
    
    If (isValidCellStr(cellStr)) Then
        cellRow = getCellRow(cellStr)
        cellCol = getCellCol(cellStr)
        If (cellRow > 1) Then
            For i = cellCol To 1 Step -1
                tmpStr = ActiveSheet.Cells(cellRow - 1, i)
                If (Len(Trim(tmpStr)) > 0) Then
                    Exit For
                End If
            Next i
        End If
        
        getExtCellValue = ActiveSheet.Cells(cellRow, cellCol) & tmpStr
    Else
        getExtCellValue = ""
    End If
    Exit Function
ErrorHandlerForGetExtCellValue:
    getExtCellValue = ""
End Function

Function getCellName(ByVal row As Integer, ByVal col As Integer) As String
    '根据行列号得到单元格名称
    Dim tmpStr As String
    Dim tmpI As Integer
    
    If (row > 0 And row < 65537 And col > 0 And col < 677) Then
        tmpI = Int((col - 1) / 26)
        getCellName = getLetter(tmpI) & getLetter(col - tmpI * 26) & row
    Else
        getCellName = ""
    End If
End Function

Function getCellRow(ByVal cellStr As String) As Integer
    '根据传入的单元格，获取单元格的行号（数字）
    '若传入"a1"，返回1
    '若传入不是一个单元格，返回-1
On Error GoTo ErrorHandlerForGetCellRow

    
    If (isValidCellStr(cellStr)) Then
        getCellRow = getNumberStringRight(cellStr)
    Else
        getCellRow = -1
    End If

    Exit Function
ErrorHandlerForGetCellRow:
    getCellRow = -1

End Function

Function getCellCol(ByVal cellStr As String) As Integer
    '返回单元格的数字列号
    '若传入的是C1，那么返回3
    '若传入的是AA1，那么返回27
On Error GoTo ErrorHandlerForGetCellCol
    Dim colNum As Integer
    
    colNum = 0
    
    If (isValidCellStr(cellStr)) Then
        For i = 1 To Len(getLetterStringLeft(cellStr))
            colNum = colNum * 26 + getLetterIndex(Mid(cellStr, i, 1))
        Next i
        getCellCol = colNum
    Else
        getCellCol = -1
    End If
    Exit Function
ErrorHandlerForGetCellCol:
    getCellCol = -1
End Function

Function isValidCellStr(ByVal aStr As String) As Boolean
    '判断字符串aStr是否代表一个单元格（有效的单元格由字母（1-2个）和数字（1-65535）组成）
On Error GoTo ErrorHandlerForIsValidCellStr
    Dim leftLetters As String
    Dim rightNumbers As Integer
    
    leftLetters = getLetterStringLeft(aStr)
    rightNumbers = Int(Val(getNumberStringRight(aStr)))
    
    '有效的单元格由字母（1-2个）和数字（1-65535）组成，这个规则是Excel 2003的，兼容后面的版本，如果超过这个，2003上不能正常使用
    If (Len(leftLetters) > 2 Or Len(leftLetters) < 1 Or rightNumbers < 1 Or rightNumbers > 65535 Or Not (leftLetters & rightNumbers) = aStr) Then
        isValidCellStr = False
    Else
        isValidCellStr = True
    End If
    
    Exit Function
ErrorHandlerForIsValidCellStr:
    isValidCellStr = False
End Function

Function getLetter(ByVal index As Integer) As String
    '根据字母在字母表的位置来获取字母（大写）
    If (index > 0 And index < 27) Then
        getLetter = Chr(index + Asc("A") - 1)
    Else
        getLetter = ""
    End If

End Function

Function getLetterIndex(ByVal aStr As String) As Integer
    '返回字母在字母表中的位置（不区分大小写），如果aStr是一个字符串，那么只判断首字母
    '如果aStr第一个字符不是一个字母，那么返回-1
    '例：若字符串是'a' 或者 "A"，那么返回 1
    '例：若字符串是'z'，那么返回 26
    '例：若字符串是'bbc'，那么返回 2
    '例：若字符串是'~!@'，那么返回 -1
On Error GoTo ErrorHandlerForGetLetterIndex
    
    If (isLetter(aStr)) Then
        getLetterIndex = Asc(UCase(aStr)) - Asc("A") + 1
    Else
        getLetterIndex = -1
    End If
    
    Exit Function
ErrorHandlerForGetLetterIndex:
    getLetterIndex = -1
    
End Function

Function isLetter(ByVal aStr As String) As Boolean
    '判断字符串aStr是否全部由字母组成
    '例：若字符串为"abcdef"，则返回True
    '    若字符串为"abc123"，则返回False
On Error GoTo ErrorHandlerForIsLetter
    
    Dim aStrUCase As String
    
    isLetter = True '初始化返回值为True
    aStrUCase = UCase(aStr) '将字符串转换为大写
    
    For i = 1 To Len(aStrUCase)
        ch = Mid(aStrUCase, i, 1)    '取字符串中的每一个字母
        If Not ((ch >= "A" And ch <= "Z")) Then    '判断是否是A-Z
            isLetter = False    '如果ch不是字母，那么跳出循环，返回值为False
            Exit For
        End If
    Next i
    Exit Function
ErrorHandlerForIsLetter:    '若发生错误，表示不是一个字母
    isLetter = False
End Function

Function isNumber(ByVal aStr As String) As Boolean
    '判断字符串aStr是否全部由数字组成
    '如字符串为"123456"，则返回True
    '如字符串为"123abc"，则返回False
On Error GoTo ErrorHandlerForIsNumber
    
    isNumber = True
    
    For i = 1 To Len(aStr)
        ch = Mid(aStr, i, 1)    '取字符串中的每一个字
        If Not ((ch >= "0" And ch <= "9")) Then    '判断是否是0-9
            isNumber = False    '如果ch不是数字，那么跳出循环，返回值为False
            Exit For
        End If
    Next i
    Exit Function
ErrorHandlerForIsNumber:
    isNumber = False
End Function

Function getLetterStringLeft(ByVal aStr As String) As String
    '获取字符串aStr中左边全部由字母组成的字符串
    '例：若字符串为"abc456def123"，则返回"abc"
On Error GoTo ErrorHandlerForGetLetterStringLeft
    
    Dim tmpStr As String
    Dim ch As String
    
    tmpStr = ""
    
    For i = 1 To Len(aStr)
        ch = Mid(aStr, i, 1)
        If Not (isLetter(ch)) Then
            Exit For
        End If
        tmpStr = tmpStr & ch
    Next i
    getLetterStringLeft = tmpStr
    
    Exit Function
    
ErrorHandlerForGetLetterStringLeft:
    getLetterStringLeft = ""
End Function

Function getNumberStringRight(ByVal aStr As String) As String
    '获取字符串aStr右边全部由数字组成的字符串
    '如字符串为"abc456def123"，则返回123
On Error GoTo ErrorHandlerForGetNumberStringRight
    
    Dim tmpStr As String
    Dim ch As String
    
    tmpStr = ""
    
    For i = Len(aStr) To 1 Step -1
        ch = Mid(aStr, i, 1)
        If Not (isNumber(ch)) Then
            Exit For
        End If
        tmpStr = ch & tmpStr
    Next i
    getNumberStringRight = tmpStr
    
    Exit Function
    
ErrorHandlerForGetNumberStringRight:
    getNumberStringRight = ""
End Function