Здравствуйте! Требуется найти в таблице города, где бизнес ведет конкретный дилер, и поместить их в одну ячейку через запятую. Более подробно - в примере. Заранее спасибо!
Здравствуйте! Требуется найти в таблице города, где бизнес ведет конкретный дилер, и поместить их в одну ячейку через запятую. Более подробно - в примере. Заранее спасибо!ex
Sub test() Dim z(), i&, i1&, j&, m& i1 = Range("B6").End(xlDown).Row z = Range("B6:C" & i1).Value With CreateObject("scripting.dictionary"): .comparemode = 1 For i = 1 To UBound(z) If .exists(z(i, 1)) = False Then m = m + 1: .Item(z(i, 1)) = m: For j = 1 To 2: z(m, j) = z(i, j): Next Else z(.Item(z(i, 1)), 2) = z(.Item(z(i, 1)), 2) & " ," & z(i, 2) End If Next Range("B19").Resize(.Count, 2).Value = z End With End Sub
Sub test() Dim z(), i&, i1&, j&, m& i1 = Range("B6").End(xlDown).Row z = Range("B6:C" & i1).Value With CreateObject("scripting.dictionary"): .comparemode = 1 For i = 1 To UBound(z) If .exists(z(i, 1)) = False Then m = m + 1: .Item(z(i, 1)) = m: For j = 1 To 2: z(m, j) = z(i, j): Next Else z(.Item(z(i, 1)), 2) = z(.Item(z(i, 1)), 2) & " ," & z(i, 2) End If Next Range("B19").Resize(.Count, 2).Value = z End With End Sub
Здравствуйте! sv2014, спасибо за ответ! А если без макроса? У меня получилось вот так (с дополнительными построениями). Но мне сказали, что можно сделать проще.
Здравствуйте! sv2014, спасибо за ответ! А если без макроса? У меня получилось вот так (с дополнительными построениями). Но мне сказали, что можно сделать проще.ex
можно так, на таблице ПКМ>Обновить (таблица справа на листе 1) В файле использовал UDF СцепитьЕсли отсюда
[vba]
Код
Function СцепитьЕсли(ByRef Диапазон As Range, ByVal Критерий As String, ByRef Диапазон_сцепления As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False) As String Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long If Диапазон.Count > 1 Then avDateArr = Intersect(Диапазон, Диапазон.Parent.UsedRange).Value avRezArr = Intersect(Диапазон_сцепления, Диапазон_сцепления.Parent.UsedRange).Value If Диапазон.Rows.Count = 1 Then avDateArr = Application.Transpose(avDateArr) avRezArr = Application.Transpose(avRezArr) End If Else ReDim avDateArr(1, 1): ReDim avRezArr(1, 1) avDateArr(1, 1) = Диапазон.Value avRezArr(1, 1) = Диапазон_сцепления.Value End If lUBnd = UBound(avDateArr, 1) 'Определяем вхождение операторов сравнения в Критерий Dim objRegExp As Object, objMatches As Object Set objRegExp = CreateObject("VBScript.RegExp") objRegExp.Global = False: objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<" Set objMatches = objRegExp.Execute(Критерий) 'Если есть вхождения If objMatches.Count > 0 Then Dim sStrMatch As String sStrMatch = objMatches.Item(0) Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2) Select Case sStrMatch Case "=" For li = 1 To lUBnd If avDateArr(li, 1) = Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case "<>" For li = 1 To lUBnd If avDateArr(li, 1) <> Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case ">=", "=>" For li = 1 To lUBnd If avDateArr(li, 1) >= Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case "<=", "=<" For li = 1 To lUBnd If avDateArr(li, 1) <= Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case ">" For li = 1 To lUBnd If avDateArr(li, 1) > Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case "<" For li = 1 To lUBnd If avDateArr(li, 1) < Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li End Select Else 'Если нет вхождения For li = 1 To lUBnd If avDateArr(li, 1) Like Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li End If
If БезПовторов Then Dim oDict As Object, sTmpStr Set oDict = CreateObject("Scripting.Dictionary") sTmpStr = Split(sStr, Разделитель) On Error Resume Next For li = LBound(sTmpStr) To UBound(sTmpStr) oDict.Add sTmpStr(li), sTmpStr(li) Next li sStr = "" sTmpStr = oDict.keys For li = LBound(sTmpStr) To UBound(sTmpStr) sStr = sStr & IIf(sStr <> "", Разделитель, "") & sTmpStr(li) Next li End If СцепитьЕсли = sStr End Function
[/vba]
можно так, на таблице ПКМ>Обновить (таблица справа на листе 1) В файле использовал UDF СцепитьЕсли отсюда
[vba]
Код
Function СцепитьЕсли(ByRef Диапазон As Range, ByVal Критерий As String, ByRef Диапазон_сцепления As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False) As String Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long If Диапазон.Count > 1 Then avDateArr = Intersect(Диапазон, Диапазон.Parent.UsedRange).Value avRezArr = Intersect(Диапазон_сцепления, Диапазон_сцепления.Parent.UsedRange).Value If Диапазон.Rows.Count = 1 Then avDateArr = Application.Transpose(avDateArr) avRezArr = Application.Transpose(avRezArr) End If Else ReDim avDateArr(1, 1): ReDim avRezArr(1, 1) avDateArr(1, 1) = Диапазон.Value avRezArr(1, 1) = Диапазон_сцепления.Value End If lUBnd = UBound(avDateArr, 1) 'Определяем вхождение операторов сравнения в Критерий Dim objRegExp As Object, objMatches As Object Set objRegExp = CreateObject("VBScript.RegExp") objRegExp.Global = False: objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<" Set objMatches = objRegExp.Execute(Критерий) 'Если есть вхождения If objMatches.Count > 0 Then Dim sStrMatch As String sStrMatch = objMatches.Item(0) Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2) Select Case sStrMatch Case "=" For li = 1 To lUBnd If avDateArr(li, 1) = Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case "<>" For li = 1 To lUBnd If avDateArr(li, 1) <> Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case ">=", "=>" For li = 1 To lUBnd If avDateArr(li, 1) >= Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case "<=", "=<" For li = 1 To lUBnd If avDateArr(li, 1) <= Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case ">" For li = 1 To lUBnd If avDateArr(li, 1) > Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li Case "<" For li = 1 To lUBnd If avDateArr(li, 1) < Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li End Select Else 'Если нет вхождения For li = 1 To lUBnd If avDateArr(li, 1) Like Критерий Then If Trim(avRezArr(li, 1)) <> "" Then _ sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1) End If Next li End If
If БезПовторов Then Dim oDict As Object, sTmpStr Set oDict = CreateObject("Scripting.Dictionary") sTmpStr = Split(sStr, Разделитель) On Error Resume Next For li = LBound(sTmpStr) To UBound(sTmpStr) oDict.Add sTmpStr(li), sTmpStr(li) Next li sStr = "" sTmpStr = oDict.keys For li = LBound(sTmpStr) To UBound(sTmpStr) sStr = sStr & IIf(sStr <> "", Разделитель, "") & sTmpStr(li) Next li End If СцепитьЕсли = sStr End Function