Сообщения

кросс

http://www.excelworld.ru/forum/10-37607-1

 Den,вариант функции

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

Function yyy&(t$)
     With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\d+"
         yyy = .Execute(t)(.Execute(t).Count - 1)
    End With
End Function

добрый день,у Вас нет дубликатов,протестируйте кнопки test1 и очистка,поэтому макрос test не срабатывает

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

Sub test()
    Dim z, t$, i&: z = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
 With CreateObject("scripting.dictionary"): .CompareMode = 1
   For i = 1 To UBound(z): t = z(i, 1): .Item(t) = .Item(t) + 1: Next
   For i = UBound(z) To 1 Step -1
        If .Item(t) > 1 Then Rows(i).Delete
   Next
End With
End Sub

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

Sub test1()
    Dim z, t$, i&: z = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
 With CreateObject("scripting.dictionary"): .CompareMode = 1
   For i = 1 To UBound(z): t = z(i, 1) : .Item(t) = .Item(t) + 1 : Next
   Range("K1").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
End With
End Sub

добрый вечер,не нашел файл-примера,как вариант вытягивания фрагмента из первого сообщения, функция uuu в C1

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

Function uuu$(t$)
  Dim t1$
With CreateObject("VBScript.RegExp"): .Pattern = "[а-яё]+\d+": .IgnoreCase = True
   t1 = .Execute(t)(0): .Pattern = "\(\d+"
 uuu = t1 & Chr(32) & Mid(.Execute(t)(0), 2)
End With
End Function

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


 

baltimor,добавил макрос для выделения цветом повторов


 

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

Sub цвет()
   Dim z, i&, j&
   z = Range("C1:C" & Range("C" & Rows.Count).End(xlUp).Row).Value
With CreateObject("scripting.dictionary")
  For i = 3 To UBound(z)
     .Item(z(i, 1)) = .Item(z(i, 1)) + 1
   Next
   For i = 3 To UBound(z)
     If .Item(z(i, 1)) > 1 Then Rows(i & ":" & i).Font.Color = -16776961
   Next
End With
End Sub

добрый вечер,baltimor,не нашел как Вам надо,вариант макроса для #1 со считыванием в массив,кнопки use и повтор


   

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

Sub use()
    Dim z, k&, j&, t$ :  z = Range("A1:I" & Range("A" & Rows.Count).End(xlUp).Row).Value
    With CreateObject("scripting.dictionary"): .CompareMode = 1
        For k = 1 To UBound(z): t = z(k, 3) & z(k, 4)
         If .exists(t) = False Then
         m = m + 1: .Item(t) = m: For j = 1 To UBound(z, 2): z(m, j) = z(k, j): Next
         Else
           z(.Item(t), 6) = z(.Item(t), 6) + z(k, 6)
         End If
   Next
   For k = 3 To UBound(z): z(k, UBound(z, 2)) = z(k, 6): Next
   Range("A1:H" &  UBound(z)).ClearContents
   Range("A1").Resize(.Count, UBound(z, 2)).Value = z
End With
End Sub

добавил еще вариант для use1,что короче

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

Sub use1()
   Dim i&, j&, i1&: i1 = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To 3
  For i = 2 To i1: Range("E" & i).Offset(, j - 1).Formula = "=uuu" & j & "(A" & i & ")"
Next i, j
End Sub

ig137,добрый день,если У Вас много строк можно вводить,как вариант, функции кнопкой,use в моем случае

 

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

Sub use()
    Dim i&, i1&: i1 = Range("A" & Rows.Count).End(xlUp).Row
  For i = 2 To i1: Range("E" & i).Formula = "=uuu1(A" & i & ")"
    Range("F" & i).Formula = "=uuu2(A" & i & ")": Range("G" & i).Formula = "=uuu3(A" & i & ")"
  Next
End Sub

вариант функций uuu1,uuu2,uuu3,соответственно в столбцах: E,F,G

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

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

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

Function uuu2(t$)
With CreateObject("VBScript.RegExp"): .Pattern = "\d+": .Global = True
    uuu2 = .Execute(t)(1)
End With
End Function

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

Function uuu3(t$)
With CreateObject("VBScript.RegExp"): .Pattern = "\d+": .Global = True
    uuu3 = .Execute(t)(.Execute(t).Count - 1)
End With
End Function

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

 

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

Sub replica(mask As Range)
   Dim i&, z, x1: x1 = Application.Transpose(mask.Value)
   z = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
        With CreateObject("vbscript.regexp"): .IgnoreCase = True: .Pattern = Join(x1, "|")
        For i = 1 To UBound(z)
           If .test(z(i, 1)) Then Range("A" & i).Interior.Color = 65535
        Next
      End With
End Sub

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

Sub use()
Dim i1&
i1 = Range("B" & Rows.Count).End(xlUp).Row
replica Range("B1:B" & i1)
End Sub

вариант для #7,вновь загруженного файла создателя темы


 

еще раз загружаю файл,использовать нижеприкрепленный,кнопки test и очистка.

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

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

Sub test()
    Dim z, i&, j&, m&, t$: z = Range("C2:I" & Range("C" & Rows.Count).End(xlUp).Row).Value
    With CreateObject("scripting.dictionary"): .CompareMode = 1
   For i = 1 To UBound(z): t = z(i, UBound(z, 2))
     If Not IsEmpty(t) And Not IsEmpty(z(i, 1)) Then
         If .exists(t) = False Then
           m = m + 1: .Item(t) = m: For j = 1 To UBound(z, 2): z(m, j) = z(i, j): Next
         Else
           z(.Item(t), 1) = z(.Item(t), 1) + z(i, 1)
         End If
      End If
   Next
  Sheets("норма на заказ").Range("A1").Resize(.Count, UBound(z, 2)).Value = z
   End With
  Sheets("норма на заказ").Columns("B:E").Delete Shift:=xlToLeft
   sort
End Sub


 

And_rey,используйте свой вариант так

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

Function толькоцифры1(MyCell As Range)
      Dim i As Integer
    For i = 1 To Len(MyCell)
        If IsNumeric(Mid(MyCell, i, 1)) Or Mid(MyCell, i, 1) = "," Then
            толькоцифры1 = толькоцифры1 + (Mid(MyCell, i, 1))
        End If
    Next
End Function