Доброго времени суток, уважаемые =) В общем задача состоит в том, чтобы транспортировать с нужным форматированием. Но из главных задач транспортировать каждую строку с значением в начале этого знака. Т.е. выделили 4 значения , получили 4 строки и т.д. Макросы нарыл которые и слегка доработал, может помощь будет какая к вашим размышлениям. Макрос транспортирования [vba]
Код
Sub ertert() Dim x, a, y(), i As Long, poz As Range x = Selection.Value ReDim y(UBound(x, 1) * UBound(x, 2)) For Each a In x y(i) = a: i = i + 1 Next On Error Resume Next Set poz = Application.InputBox("Выберите ячейку для вставки", Type:=8) If Not poz Is Nothing Then poz.Resize(, UBound(y)).Value = y End Sub
[/vba] Макрос добавления кавычек [vba]
Код
Sub ДобавитьСимволВвыделенныеЯчейки(): For Each cell In Selection: cell.Value = """" & cell.Value & """": Next: End Sub
[/vba] Макрос объединения [vba]
Код
Sub MergeToOneCell() Const sDELIM As String = " " 'символ-разделитель Dim rCell As Range Dim sMergeStr As String If TypeName(Selection) <> "Range" Then Exit Sub 'если выделены не ячейки - выходим With Selection For Each rCell In .Cells sMergeStr = sMergeStr & sDELIM & rCell.Text 'собираем текст из ячеек Next rCell Application.DisplayAlerts = False 'отключаем стандартное предупреждение о потере текста .Merge Across:=False 'объединяем ячейки Application.DisplayAlerts = True .Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM)) 'добавляем к объед.ячейке суммарный текст
End With '________________отменяем объединить Selection.UnMerge '________________ End Sub
[/vba]
В примере столбик подписан итог, то что хотелось бы получить в итоге. Числа рандомные.
Доброго времени суток, уважаемые =) В общем задача состоит в том, чтобы транспортировать с нужным форматированием. Но из главных задач транспортировать каждую строку с значением в начале этого знака. Т.е. выделили 4 значения , получили 4 строки и т.д. Макросы нарыл которые и слегка доработал, может помощь будет какая к вашим размышлениям. Макрос транспортирования [vba]
Код
Sub ertert() Dim x, a, y(), i As Long, poz As Range x = Selection.Value ReDim y(UBound(x, 1) * UBound(x, 2)) For Each a In x y(i) = a: i = i + 1 Next On Error Resume Next Set poz = Application.InputBox("Выберите ячейку для вставки", Type:=8) If Not poz Is Nothing Then poz.Resize(, UBound(y)).Value = y End Sub
[/vba] Макрос добавления кавычек [vba]
Код
Sub ДобавитьСимволВвыделенныеЯчейки(): For Each cell In Selection: cell.Value = """" & cell.Value & """": Next: End Sub
[/vba] Макрос объединения [vba]
Код
Sub MergeToOneCell() Const sDELIM As String = " " 'символ-разделитель Dim rCell As Range Dim sMergeStr As String If TypeName(Selection) <> "Range" Then Exit Sub 'если выделены не ячейки - выходим With Selection For Each rCell In .Cells sMergeStr = sMergeStr & sDELIM & rCell.Text 'собираем текст из ячеек Next rCell Application.DisplayAlerts = False 'отключаем стандартное предупреждение о потере текста .Merge Across:=False 'объединяем ячейки Application.DisplayAlerts = True .Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM)) 'добавляем к объед.ячейке суммарный текст
End With '________________отменяем объединить Selection.UnMerge '________________ End Sub
[/vba]
В примере столбик подписан итог, то что хотелось бы получить в итоге. Числа рандомные.televnoy
Option Explicit '--------------------------------------------------------------------------------------- ' Procedure : СцепитьМного ' http://www.excel-vba.ru ' Purpose : Функция сцепляет все указанные ячейки в одну с указанным разделителем. Допускается указание несмежных диапазонов ' Аргументы функции: ' Диапазон — диапазон ячеек, значения которых необходимо объединить в строку. ' Разделитель — необязательный аргумент. ' Один или несколько символов, которые будут вставлены между каждым словом. ' По умолчанию пробел. ' БезПовторов — необязательный аргумент. ' Если указан как ИСТИНА или 1 — в результирующей строке будут значения без дубликатов. ' Для английской локализации данный параметр указывается как TRUE и FALSE соответственно. '--------------------------------------------------------------------------------------- Function СцепитьМного(диапазон As Range, Optional разделитель As String = ", ", Optional БезПовторов As Boolean = False) Dim avData, lr As Long, lc As Long, sRes As String Dim ra As Range
For Each ra In диапазон.Areas avData = ra.Value If Not IsArray(avData) Then ReDim avData(1 To 1, 1 To 1) avData(1, 1) = ra.Value 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) & """" End If Next lr Next lc Next If Len(sRes) Then sRes = Mid(sRes, Len(разделитель) + 1) End If
If БезПовторов Then Dim oDict As Object, sTmpStr Set oDict = CreateObject("Scripting.Dictionary") sTmpStr = Split(sRes, разделитель) On Error Resume Next For lr = LBound(sTmpStr) To UBound(sTmpStr) oDict.Add sTmpStr(lr), sTmpStr(lr) Next lr sRes = "" sTmpStr = oDict.Keys For lr = LBound(sTmpStr) To UBound(sTmpStr) sRes = sRes & IIf(sRes <> "", разделитель, "") & sTmpStr(lr) Next lr End If СцепитьМного = sRes End Function
[/vba]
Требуется вводить формулу:
Код
=СцепитьМного()
Хотелось бы чтобы это был макрос Не разобрался как к первому значению прикрепить 0 И не знаю как быть с остальным диапазоном, чтобы он принял окончательный вид.
Нашел функцию сцепить. [vba]
Код
Option Explicit '--------------------------------------------------------------------------------------- ' Procedure : СцепитьМного ' http://www.excel-vba.ru ' Purpose : Функция сцепляет все указанные ячейки в одну с указанным разделителем. Допускается указание несмежных диапазонов ' Аргументы функции: ' Диапазон — диапазон ячеек, значения которых необходимо объединить в строку. ' Разделитель — необязательный аргумент. ' Один или несколько символов, которые будут вставлены между каждым словом. ' По умолчанию пробел. ' БезПовторов — необязательный аргумент. ' Если указан как ИСТИНА или 1 — в результирующей строке будут значения без дубликатов. ' Для английской локализации данный параметр указывается как TRUE и FALSE соответственно. '--------------------------------------------------------------------------------------- Function СцепитьМного(диапазон As Range, Optional разделитель As String = ", ", Optional БезПовторов As Boolean = False) Dim avData, lr As Long, lc As Long, sRes As String Dim ra As Range
For Each ra In диапазон.Areas avData = ra.Value If Not IsArray(avData) Then ReDim avData(1 To 1, 1 To 1) avData(1, 1) = ra.Value 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) & """" End If Next lr Next lc Next If Len(sRes) Then sRes = Mid(sRes, Len(разделитель) + 1) End If
If БезПовторов Then Dim oDict As Object, sTmpStr Set oDict = CreateObject("Scripting.Dictionary") sTmpStr = Split(sRes, разделитель) On Error Resume Next For lr = LBound(sTmpStr) To UBound(sTmpStr) oDict.Add sTmpStr(lr), sTmpStr(lr) Next lr sRes = "" sTmpStr = oDict.Keys For lr = LBound(sTmpStr) To UBound(sTmpStr) sRes = sRes & IIf(sRes <> "", разделитель, "") & sTmpStr(lr) Next lr End If СцепитьМного = sRes End Function
[/vba]
Требуется вводить формулу:
Код
=СцепитьМного()
Хотелось бы чтобы это был макрос Не разобрался как к первому значению прикрепить 0 И не знаю как быть с остальным диапазоном, чтобы он принял окончательный вид.televnoy
Sub www() Dim i1&, i2&, s&, i&, j& i1 = Selection.Cells(1).Row i2 = Selection.Cells(Selection.Cells.Count).Row s = i1 For i = i1 To i2 Cells(s, 5) = """0" & Cells(i, 4) & """" For j = i1 To i2 If Cells(j, 4) <> Cells(i, 4) Then Cells(s, 5) = Cells(s, 5) & ", " & """" & Cells(j, 4) & """" & " " End If Next s = s + 1 Next End Sub
[/vba]
Так, что ли, надо? [vba]
Код
Sub www() Dim i1&, i2&, s&, i&, j& i1 = Selection.Cells(1).Row i2 = Selection.Cells(Selection.Cells.Count).Row s = i1 For i = i1 To i2 Cells(s, 5) = """0" & Cells(i, 4) & """" For j = i1 To i2 If Cells(j, 4) <> Cells(i, 4) Then Cells(s, 5) = Cells(s, 5) & ", " & """" & Cells(j, 4) & """" & " " End If Next s = s + 1 Next End Sub