按指定条件连接A列数据

lsdongjh · 发表于 2018-12-20 17:39

Function SSLJ(rgData As Range, Optional LineType As Variant = "", Optional DispLocation As Variant = "") As Variant
Dim rgFormula As Range '公式所在区域
Dim arrData As Variant, strResult() As String
Dim lngRows As Long, lngCols As Long
Dim lngR As Long, lngC As Long
Dim strTemp As String, strLast As String
Dim lngLen As Long, lngMod As Long
Dim arrTemp As Variant, lngIndex As Long
Dim lngLineType As Long, lngDispLocation As Long
Set rgFormula = Application.Caller
lngRows = rgFormula.Rows.Count
lngCols = rgFormula.Columns.Count
ReDim strResult(1 To lngRows, 1 To lngCols) As String
If LineType = "" Then
lngLineType = 0
Else
lngLineType = Val(LineType)
End If
If DispLocation = "" Then
lngDispLocation = 0
Else
lngDispLocation = Val(DispLocation) - rgFormula.Row + 1
End If
If rgData.Rows.Count < 3 Then Exit Function '如果不足3行，直接退出
arrData = rgData
arrData = Application.WorksheetFunction.Transpose(arrData)
strTemp = Join(arrData, ""): strTemp = Replace(strTemp, Space(1), "")
lngLen = Len(strTemp)
strLast = Mid(strTemp, lngLen - 1): strTemp = Mid(strTemp, 1, lngLen - 2)
lngLen = lngLen - 2: lngMod = lngLen Mod 3: lngLen = lngLen \ 3
strTemp = Mid(strTemp, lngMod + 1)
ReDim arrTemp(1 To lngLen)
For lngMod = 1 To lngLen
arrTemp(lngMod) = Mid(strTemp, 1 + (lngMod - 1) * 3, 3)
Next
If lngDispLocation < 0 Then lngDispLocation = UBound(arrTemp)
lngMod = lngDispLocation - lngLen
lngLen = lngDispLocation - UBound(arrTemp) + 1
If lngLen < 1 Then lngLen = 1
For lngIndex = lngDispLocation To lngLen Step -1
strResult(lngIndex, 1) = arrTemp(lngIndex - lngMod)
Next
If lngLineType <> 0 Then strResult(lngDispLocation + 1, 1) = strLast
SSLJ = strResult
End Function

复制代码

lsdongjh · 发表于 2018-12-20 17:48

上面的代码中，有个bug，自己修正一下：
If lngDispLocation <= 0 Then lngDispLocation = UBound(arrTemp)

lsdongjh · 发表于 2018-12-20 17:49

完整

Function SSLJ(rgData As Range, Optional LineType As Variant = "", Optional DispLocation As Variant = "") As Variant
Dim rgFormula As Range '公式所在区域
Dim arrData As Variant, strResult() As String
Dim lngRows As Long, lngCols As Long
Dim lngR As Long, lngC As Long
Dim strTemp As String, strLast As String
Dim lngLen As Long, lngMod As Long
Dim arrTemp As Variant, lngIndex As Long
Dim lngLineType As Long, lngDispLocation As Long
Set rgFormula = Application.Caller
lngRows = rgFormula.Rows.Count
lngCols = rgFormula.Columns.Count
ReDim strResult(1 To lngRows, 1 To lngCols) As String
If LineType = "" Then
lngLineType = 0
Else
lngLineType = Val(LineType)
End If
If DispLocation = "" Then
lngDispLocation = 0
Else
lngDispLocation = Val(DispLocation) - rgFormula.Row + 1
End If
If rgData.Rows.Count < 3 Then Exit Function '如果不足3行，直接退出
arrData = rgData
arrData = Application.WorksheetFunction.Transpose(arrData)
strTemp = Join(arrData, ""): strTemp = Replace(strTemp, Space(1), "")
lngLen = Len(strTemp)
strLast = Mid(strTemp, lngLen - 1): strTemp = Mid(strTemp, 1, lngLen - 2)
lngLen = lngLen - 2: lngMod = lngLen Mod 3: lngLen = lngLen \ 3
strTemp = Mid(strTemp, lngMod + 1)
ReDim arrTemp(1 To lngLen)
For lngMod = 1 To lngLen
arrTemp(lngMod) = Mid(strTemp, 1 + (lngMod - 1) * 3, 3)
Next
If lngDispLocation <= 0 Then lngDispLocation = UBound(arrTemp)
lngMod = lngDispLocation - lngLen
lngLen = lngDispLocation - UBound(arrTemp) + 1
If lngLen < 1 Then lngLen = 1
For lngIndex = lngDispLocation To lngLen Step -1
strResult(lngIndex, 1) = arrTemp(lngIndex - lngMod)
Next
If lngLineType <> 0 Then strResult(lngDispLocation + 1, 1) = strLast
SSLJ = strResult
End Function

复制代码

WYS67 · 发表于 2018-12-20 17:59

lsdongjh 发表于 2018-12-20 17:49
完整

十分钦佩老师严谨的编码态度！刚要向您反馈C:D列省略第三参数后，不显示三位数计算结果的问题，您就上传了完整的代码。经过测试，完全正确！非常完美地实现了我的初衷！

谢谢老师的辛勤付出！

		自动登录	找回密码
密码			免费注册

[求助] 按指定条件连接A列数据

评分

评分