اذهب الي المحتوي
أوفيسنا

الردود الموصى بها

  • أفضل إجابة
قام بنشر

جرب هذا الكود

Option Explicit
Sub Extract_by_Groupes()
Rem         Created By Salim Hasbaya On 19/2/2020
If ActiveSheet.Name <> "Salim" Then Exit Sub
Dim ObjReg As Object
Dim ObjMatches, a%, My_word, i%
Dim k%, col%, last_row
last_row = Cells(Rows.Count, 1).End(3).Row
Range("C1:E" & last_row).Clear
Set ObjReg = CreateObject("VBScript.RegExp")
With ObjReg
.Pattern = "(\w+)\s*?(\d+)\s*?([(]\s*?.\s*.+)"
.Global = True
End With
For k = 1 To last_row
 If ObjReg.test(Range("a" & k)) Then
Set ObjMatches = ObjReg.Execute(Range("a" & k))
 For Each My_word In ObjMatches             'The variable match will contain the full match
    a = My_word.Submatches.Count           'total number of groups in the full match
    col = 3
    For i = 0 To a - 1
     Cells(k, col) = My_word.Submatches(i)
     col = col + 1
    Next
Next
End If
col = 3
Next
    With Range("C1:E" & last_row)
    .Borders.LineStyle = 1
    .Font.Size = 14
    .Font.Bold = True
    .InsertIndent 1
    .Columns.AutoFit
    .Interior.ColorIndex = 15
    End With
Set ObjReg = Nothing
End Sub

الملف مرفق

Ungroup_Text.xlsm

  • Like 1

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information