Сообщения

margo,добрый день,потестируйте макрос,кнопки example,test.
Сцеплять  можно и макросом

Код (vb) Выделить Развернуть

Sub example()
   Dim i&, x()
   With ActiveSheet
      x = .UsedRange.Value
       For i = 1 To UBound(x)
       x(i, 1) = x(i, 1) & x(i, 2)
       Next
     .Range("C1").Resize(UBound(x), 1).Value = x
  End With
End Sub

добрый вечер ,попробуйте протестировать пользовательскую функцию VBA
в файл-примере кнопка test справа,кнопка очистить для тестирования.

   

Код (vb) Выделить Развернуть

Function zzz$(t1$)
     Dim x
      x = Split(t1)
     zzz = x(UBound(x)) & "," & Left(x(UBound(x) - 1), Len(x(UBound(x) - 1)) - 1)
End Function

Доброго времени суток ,Ran,
  Вы не посмотрели,что в столбцах E8:E12,G8:G12 имеются другие функции,вот чуть измененный пример,
для вашего знакомого,который в командировке 3650 дней

 

Код (vb) Выделить Развернуть

Function uu$(st$)
    Dim i1$, i2$, i3$
With CreateObject("VBScript.RegExp"): .Global = True
  .Pattern = "\b\d{1,4}\b"
      If .test(st) Then
         i3 = .Execute(st)(.Execute(st).Count - 1).Value
      End If
  .Pattern = "\b\d{3}\b"
      If .test(st) Then
        i2 = .Execute(st)(0).Value
      End If
  .Pattern = "\b\d{1}\b"
     If .test(st) Then
        i1 = .Execute(st)(0).Value
     End If
      uu = i1 & "*" & i2 & "*" & i3
End With
End Function

The_Prist,благодарю за Ваш ответ и ответ Ran,повторю,-в диапазоне L8:L12 находится Ваш вариант,а именно,ответ#5 от 3-10-2015,22:38:24,трижды скопировал этот вариант(ответ#5)
в прикрепленном файл-примере к данному сообщению:
   в диапазоны P8:P12,Q8:Q12,R8:R12,результат одинаковый,попробуйте сами скопировать в соседний диапазон.
В целом,считаю,что это непринципиальный момент,нисколько не собираюсь подвергать сомнению Ваш высокий авторитет
как Модератора ,с уважением ко всем участникам обсуждения.

Добрый вечер
спасибо The_Prist,что уделили внимание,
уточняю:
  Ваш последний вариант в файл-примере,в диапазоне O8:O12 ,первоначальный Ваш вариант в диапазоне L8:L12,
в диапазонах K8:K12 и M8:M12-это мои предложенные версии.

добрый день,вариант функции в другом формате,кнопка test в файл примере.

 

Код (vb) Выделить Развернуть

Function uu$(st$)
    Dim i1$, i2$, i3$
With CreateObject("VBScript.RegExp"): .Global = True
  .Pattern = "\b\d{1,2}\b"
      If .test(st) Then
         i3 = .Execute(st)(.Execute(st).Count - 1).Value
      End If
  .Pattern = "\b\d{3}\b"
      If .test(st) Then
        i2 = .Execute(st)(0).Value
      End If
  .Pattern = "\b\d{1}\b"
     If .test(st) Then
        i1 = .Execute(st)(0).Value
     End If
      uu = i1 & "*" & i2 & "*" & i3
End With
End Function

вариант обычной функции

   

Код (vb) Выделить Развернуть

=ПОДСТАВИТЬ(ПСТР($B8;ПОИСК("Количество человек*";$B8)+20;2)&"*"&ПСТР($B$8;ПОИСК("норма суточных*";$B$8)+16;4)&"*"&ПСТР($B8;ПОИСК("продолж командировки*";$B8)+22;2);" ";"")

вариант для функции от The_Prist
 

Код (vb) Выделить Развернуть

=ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПСТР(B8;ПОИСК("Количество человек*;";B8)+20;2)&"*"&ПСТР(B8;ПОИСК("норма суточных*;";B8)+16;4)&"*"&ПСТР(B8;ПОИСК("продолж командировки*";B8)+22;7);"дн";"");" ";"")


Уважаемый The_Prist,доброго времени суток.
Ваш вариант формулы ,в файл-примере, в столбце L8:L12,требует корректировки до варианта в столбце K8:K12(работает),
возможен вариант с одной функцией Подставить вместо двух, в столбце M8:M12(работает).
Причина корректировки:не нужны пробелы между Количество человек и *,между норма суточных и *, между продолж командировки *,вместо 9 надо соответственно 7

Serditof.добрый день,итоговая функция( кнопка test в файл-примере:

 

Код (vb) Выделить Развернуть

Function uu%(st$)
    Dim i1%, i2%, i3%
With CreateObject("VBScript.RegExp"): .Global = True
  .Pattern = "\b\d{1,2}\b"
      If .test(st) Then
         i3 = CInt(.Execute(st)(.Execute(st).Count - 1).Value)
      End If
  .Pattern = "\b\d{3}\b"
      If .test(st) Then
        i2 = CInt(.Execute(st)(0).Value)
      End If
  .Pattern = "\b\d{1}\b"
     If .test(st) Then
        i1 = CInt(.Execute(st)(0).Value)
     End If
      uu = i1 * i2 * i3
End With
End Function

доброго времени суток,попробуйте протестировать

Код (vb) Выделить Развернуть

Function uu3%(st$)
With CreateObject("VBScript.RegExp")
 .Pattern = "\b\d{1,2}\b"
 .Global = True
 uu3 = CInt(.Execute(st).Item(.Execute(st).Count - 1).Value)
End With
End Function

Function uu2%(st$)
With CreateObject("VBScript.RegExp")
 .Pattern = "\b\d{3}\b"
 .Global = True
 uu2 = CInt(.Execute(st).Item(0).Value)
End With
End Function

Function uu1%(st$)
With CreateObject("VBScript.RegExp")
 .Pattern = "\b\d{1}\b"
 .Global = True
 uu1 = CInt(.Execute(st).Item(0).Value)
End With
End Function

Уточню, выдают такие результаты 17683 и 15446(видимо это курс белорусского рубля) соответственно.

Добрый день,  у меня работает почему-то только  функция от ThePrist КУРСЦБР,вариант от Doober  КУРСЦБР1
выдает ошибку и вариант от TheBestOfTheBest КУРСЦБР2 выдает ошибку.

Elena666, или используйте в своем макросе соответствующую такую строку:

Код (vb) Выделить Развернуть

lLastCol = Cells(3, Cells.Columns.Count).End(xlToLeft).Column

Elena666, вариант Вашего макроса:

Код (vb) Выделить Развернуть

Private Sub CommandButton1_Click()
  With Лист1
  Dim lLastCol As Long
  lLastCol = Cells(3, 1).End(xlToRight).Column
     Cells(3, lLastCol + 1).Value = TextBox1.Value '
     Cells(3, lLastCol + 2).Value = TextBox2.Value '
     Cells(3, lLastCol + 3).Value = TextBox3.Value '
   End With
End Sub

Добрый день попробуйте  макросы (второй во вложенном файле):
Почему-то при копировании вносится дополнительный текст.

Код (vb) Выделить Развернуть

Sub example1()
   Dim i&, i1&, i2&
   Dim w1 As Worksheet, w2 As Worksheet
   Set w1 = Sheets("База инструмента")
   Set w2 = Sheets("Результат")
   i1 = w1.Range("A" & w1.Cells.Rows.Count).End(xlUp).Row
   i2 = w2.Range("A" & w1.Cells.Rows.Count).End(xlUp).Row
   With w2
      For i = 1 To i2
        w2.Range("$B" & i).Formula = _
        "=VLOOKUP(Результат!$A$" & i & ",'База инструмента'!$A$1:$B$" & i2 & ",2,FALSE)"
       Next
   End With
End Sub

 
Elena666,попробуйте заменить  вашу строку 7 на:

Код (vb) Выделить Развернуть

sluch = Int(Rnd() * (5) + 1)