|
- Option Explicit
- Function QSPW(rgData As Range, Optional arrIndex As Variant = 4) As Variant
- Dim arrTitle As Variant, arrData As Variant, rgCur As Range
- Dim lngRow As Long, lngCol As Long
- Dim lngVal(1 To 9) As Long, strVal(1 To 9) As String
- Dim arrResult As Variant, arrReturn As Variant, lngID As Long
- Dim lngIndex As Long, strTemp(1 To 3) As String, strAll As String
-
- arrTitle = rgData.Offset(-1, 0).Resize(1) '标题区域是数据区域的上一行
- arrData = rgData
- lngID = arrIndex
-
- Set rgCur = Application.Caller
- ReDim arrResult(1 To rgCur.Rows.Count, 1 To 4) As String
- Set rgCur = Nothing
-
- For lngRow = LBound(arrData) To UBound(arrData)
- If arrData(lngRow, 1) = "" Then Exit For
- For lngCol = 1 To 9
- strVal(lngCol) = arrData(lngRow, lngCol) & strVal(lngCol)
- lngVal(lngCol) = Val(Trim(Mid(strVal(lngCol), 1, 7)) & arrTitle(1, lngCol))
- Next
-
- lngIndex = lngIndex + 1: strAll = ""
- For lngCol = 1 To 3
- strTemp(lngCol) = Right(CStr(Application.WorksheetFunction.Large(lngVal, lngCol)), 1)
- strAll = strAll & strTemp(lngCol)
- arrResult(lngIndex, lngCol) = strTemp(lngCol)
- Next
- arrResult(lngIndex, 4) = strAll
- Next
-
- arrReturn = Application.WorksheetFunction.Index(arrResult, 0, lngID)
- QSPW = arrReturn
- End Function
复制代码 |
评分
-
1
查看全部评分
-
|