Сообщения

добрый вечер,вариант функции uuu в C1

 

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

Function uuu#(t$)
With CreateObject("VBScript.RegExp"): .Pattern = "\d+,\d+"
    uuu = .Execute(t)(0)
End With
End Function

 доброго времени суток,Стрель,вариант макроса,кнопки test и повтор.


 

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

Sub test()
   Dim z, i&
With CreateObject("VBScript.RegExp"): .Pattern = ".+ \d+\.\d+"
    z = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
    For i = 1 To UBound(z)
   z(i, 1) = .Execute(z(i, 1))(0)
   Next
  Range("A1").Resize(UBound(z), 1).Value = z
  End With
End Sub

добрый вечер,Стрель,вариант функции uuu1 в столбце K

 

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

Function uuu1$(t$)
With CreateObject("VBScript.RegExp"): .Pattern = ".+ \d+\.\d+"
    uuu1 = .Execute(t)(0)
End With
End Function

добрый вечер,вариант функций:uuu1 в E16,uuu2 в Е17,uuu3 в F16.Преимущество таких функций-простота

 

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

Function uuu1%(r As Range)
   Dim i&, z: z = r.Value
For i = 1 To UBound(z)
   If Not IsEmpty(z(i, 1)) And z(i, 1) <> "!" Then uuu1 = uuu1 + 1
Next
End Function

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

Function uuu2%(r As Range)
  Dim i&, z: z = r.Value
For i = 1 To UBound(z)
   If IsNumeric(z(i, 1)) And z(i, 1) >= 2 Then uuu2 = uuu2 + 1
Next
End Function

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

Function uuu3%(r As Range)
Dim i&, z: z = r.Value
For i = 1 To UBound(z)
    With CreateObject("VBScript.RegExp"): .Pattern = "[^! ]"
   If .test(z(i, 1)) Then uuu3 = uuu3 + 1
    End With
Next
End Function


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

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

Sub test()
   Dim i&, x
   x = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
       For i = 1 To UBound(x)
         x(i, 1) = -x(i, 1)
       Next
  Range("A1").Resize(UBound(x), 1).Value = x
End Sub

kisula,вариант с функцией в столбце C,вариант Victtur в столбце B

   

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

Function zzz$(t$)
  zzz = "0" & Split(t, ";")(0)
End Function

Viktoria91,еще вариант,чуть покороче макрос use1

 

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

Sub replica2(r As Range)
    Dim i&, x(), c As Range
    For Each c In r: c = Trim(c): Next
    x = Range("B4:E" & Range("B" & Rows.Count).End(xlUp).Row).Value
        With CreateObject("vbscript.regexp"): .Pattern = Join(Application.Transpose(r), "|")
        For i = 1 To UBound(x)
           If .test(x(i, 1)) Then x(i, 4) = True Else x(i, 4) = False
        Next
      End With
    Range("B4").Resize(UBound(x), UBound(x, 2)).Value = x
End Sub

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

Sub use1()
replica2 Range("C4:C" & Range("C" & Rows.Count).End(xlUp).Row)
End Sub

добрый вечер,Viktoria91.еще вариант макроса use,кнопка use

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

Sub replica1(mask As Range)
    Dim i&, x(), cell As Range
For Each cell In mask: cell = Application.WorksheetFunction.Trim(cell.Value): Next
    x = Range("B4:E" & Range("B" & Cells.Rows.Count).End(xlUp).Row).Value
        With CreateObject("vbscript.regexp"): .Pattern = Join(Application.Transpose(mask.Value), "|")
        For i = 1 To UBound(x)
           If .test(x(i, 1)) Then x(i, 4) = True Else x(i, 4) = False
        Next
      End With
    Range("B4").Resize(UBound(x), UBound(x, 2)).Value = x
End Sub

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

[code=vb]Sub use()
replica1 Range("C4:C" & Range("C" & Rows.Count).End(xlUp).Row)
End Sub[/code]

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

Sub очистка()
Range("E4:E" & Range("E" & Rows.Count).End(xlUp).Row).ClearContents
End Sub

добрый день,попробуйте так

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

Sub Main1()
Dim A As Integer, B As Integer, C As Integer, X1 As Double, X2 As Double
   Worksheets(1).Name = "Кв.уравнения"
   Worksheets(1).Cells(2, 5) = ""
   A = Worksheets(1).Cells(2, 1).Value
   B = Worksheets(1).Cells(2, 2).Value
   C = Worksheets(1).Cells(2, 3).Value
   If A = 0 Then Worksheets(1).Cells(2, 4).Value = "Уравнение не является квадратным!": Exit Sub
   D = B ^ 2 - 4 * A * C
   If D < 0 Then Worksheets(1).Cells(2, 4).Value = "Уравнение вещественных корней не имеет!": Exit Sub
           X1 = (-B + D ^ (1 / 2)) / (2 * A)
           X2 = (-B - D ^ (1 / 2)) / (2 * A)
           Worksheets(1).Cells(2, 4) = X1
           Worksheets(1).Cells(2, 5) = X2
End Sub

добрый вечер,rogge,попробуйте так

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

Sub smth1()
    Dim a() As Integer
    Dim max(), n%, m%, i%, j%
    n = CInt(InputBox("ââåäèòå ÷èñëî n"))
    m = CInt(InputBox("ââåäèòå ÷èñëî m"))
    ReDim a(1 To 10, 1 To 10) As Integer
For i = 1 To m
For j = 1 To n
   a(i, j) = InputBox("A(" & i & " , " & j & " ) ")
Next j, i
For j = 1 To n
  ReDim Preserve max(1 To j)
  max(j) = a(1, j)
For i = 2 To m
  If a(i, j) > max(j) Then
    max(j) = a(i, j)
  End If
Next i, j
  For i = 1 To n
   MsgBox max(i)
  Next
End Sub

добавлю,обычные формулы также без кавычек все вытягивают, столбец E в файл-примере,
в E1 подставить равно

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

= ПСТР(A1;3;5)

добавлю,такой же результат

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

 Function yyy1(t$)
    With CreateObject("VBScript.RegExp") : .Pattern = "[а-яё]+"    
       If .test(t) Then yyy1 = .Execute(t)(0)
   End With
End Function

добрый деь,Serditof,попробуйте пользовательскую функцию в файл-примере,функцию можно усовершенствовать.

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

Function yyy(t$)
     With CreateObject("VBScript.RegExp")
        .Pattern = "\""([а-яё]+)\"""
        If .test(t) Then yyy = .Execute(t)(0).Submatches(0)
    End With
End Function

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


   

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

Function uuu$(t$)
   Dim i%, s$
   For i = 1 To 6
     s = s & Mid(t, i, 1)
   Next
    uuu = s & "*" & Mid(t, 8, 1) & "*" & "*" & Mid(t, 11, 1)
End Function

добрый день ,можно так,то есть трижды применить Заменить

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

= ЗАМЕНИТЬ(ЗАМЕНИТЬ(ЗАМЕНИТЬ(A1;10;1;"*");9;1;"*");7;1;"*")