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