Здравствуйте. Остальные варианты для множественного числа сами добавите.
[vba]
Код
Function СцепитьМного(Диапазон As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False) Dim avData, lr As Long, lc As Long, sRes As String, key As String Dim oDict As Object, sTmpStr Set oDict = CreateObject("Scripting.Dictionary") oDict.comparemode = 1
avData = Диапазон.Value If Not IsArray(avData) Then СцепитьМного = avData Exit Function End If
For lc = 1 To UBound(avData, 2) For lr = 1 To UBound(avData, 1) If Len(avData(lr, lc)) Then sRes = sRes & Разделитель & avData(lr, lc) If БезПовторов Then key = avData(lr, lc) If key <> "" Then key = Trim(Split(key, "-")(0)) If Not oDict.exists(key) Then oDict.Add key, 1 Else oDict.Item(key) = 2
End If End If End If Next lr Next lc If Len(sRes) Then sRes = Mid(sRes, Len(Разделитель) + 1) End If
If БезПовторов Then sRes = "" sTmpStr = oDict.keys For lr = 0 To oDict.Count - 1 key = sTmpStr(lr) ct& = oDict.Item(key) If ct& > 1 Then '' Здесь обрабатывайте множественное число ll = Len(key) Select Case Right(key, 1) Case "т", "м" sRes = sRes & IIf(sRes <> "", Разделитель, "") & key & "ы" Case "к" sRes = sRes & IIf(sRes <> "", Разделитель, "") & key & "и" Case "а" sRes = sRes & IIf(sRes <> "", Разделитель, "") & Mid(key, 1, ll - 1) & "и" Case "е", "и" sRes = sRes & IIf(sRes <> "", Разделитель, "") & key
End Select
Else sRes = sRes & IIf(sRes <> "", Разделитель, "") & key End If
Next lr End If СцепитьМного = sRes End Function
[/vba]
Здравствуйте. Остальные варианты для множественного числа сами добавите.
[vba]
Код
Function СцепитьМного(Диапазон As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False) Dim avData, lr As Long, lc As Long, sRes As String, key As String Dim oDict As Object, sTmpStr Set oDict = CreateObject("Scripting.Dictionary") oDict.comparemode = 1
avData = Диапазон.Value If Not IsArray(avData) Then СцепитьМного = avData Exit Function End If
For lc = 1 To UBound(avData, 2) For lr = 1 To UBound(avData, 1) If Len(avData(lr, lc)) Then sRes = sRes & Разделитель & avData(lr, lc) If БезПовторов Then key = avData(lr, lc) If key <> "" Then key = Trim(Split(key, "-")(0)) If Not oDict.exists(key) Then oDict.Add key, 1 Else oDict.Item(key) = 2
End If End If End If Next lr Next lc If Len(sRes) Then sRes = Mid(sRes, Len(Разделитель) + 1) End If
If БезПовторов Then sRes = "" sTmpStr = oDict.keys For lr = 0 To oDict.Count - 1 key = sTmpStr(lr) ct& = oDict.Item(key) If ct& > 1 Then '' Здесь обрабатывайте множественное число ll = Len(key) Select Case Right(key, 1) Case "т", "м" sRes = sRes & IIf(sRes <> "", Разделитель, "") & key & "ы" Case "к" sRes = sRes & IIf(sRes <> "", Разделитель, "") & key & "и" Case "а" sRes = sRes & IIf(sRes <> "", Разделитель, "") & Mid(key, 1, ll - 1) & "и" Case "е", "и" sRes = sRes & IIf(sRes <> "", Разделитель, "") & key
End Select
Else sRes = sRes & IIf(sRes <> "", Разделитель, "") & key End If