Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Транспортировать с форматированием - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Транспортировать с форматированием (Макросы/Sub)
Транспортировать с форматированием
televnoy Дата: Воскресенье, 17.12.2017, 12:48 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 119
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Доброго времени суток, уважаемые =)
В общем задача состоит в том, чтобы транспортировать с нужным форматированием. Но из главных задач транспортировать каждую строку с значением в начале этого знака.
Т.е. выделили 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]

В примере столбик подписан итог, то что хотелось бы получить в итоге. Числа рандомные.
К сообщению приложен файл: tranport1.xls(47.0 Kb)


О-па! 0_o
 
Ответить
СообщениеДоброго времени суток, уважаемые =)
В общем задача состоит в том, чтобы транспортировать с нужным форматированием. Но из главных задач транспортировать каждую строку с значением в начале этого знака.
Т.е. выделили 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
Дата добавления - 17.12.2017 в 12:48
televnoy Дата: Воскресенье, 17.12.2017, 14:00 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 119
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Нашел функцию сцепить.
[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
И не знаю как быть с остальным диапазоном, чтобы он принял окончательный вид.
К сообщению приложен файл: tranport2.xls(54.5 Kb)


О-па! 0_o
 
Ответить
СообщениеНашел функцию сцепить.
[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
Дата добавления - 17.12.2017 в 14:00
Wasilich Дата: Понедельник, 18.12.2017, 07:29 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 325 ±
Замечаний: 0% ±

2003
Так, что ли, надо?
[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
[/vba]
К сообщению приложен файл: televnoy.xls(54.5 Kb)
 
Ответить
СообщениеТак, что ли, надо?
[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
[/vba]

Автор - Wasilich
Дата добавления - 18.12.2017 в 07:29
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Транспортировать с форматированием (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!