معادلة طرح تاريخين & معادلة فصل النص عن الأرقام

[محمود محمود احمد]

السلام عليكم احبتي الكرام........... عندي سؤالين 1 طرح التاريخ والثاني فصل القيم عن النص

طرح تاريخ.xlsx

[Ali Mohamed Ali]

وعليكم السلام-تفضل لك ما طلبت

 

طرح تاريخ.xlsm

[سليم حاصبيا]

بعد اذن الاخ علي

هذا الكود

Option Explicit
Sub Extract_by_Groupes()
Rem         Created By Salim Hasbaya On 19/2/2020
If ActiveSheet.Name <> "ورقة1" Then Exit Sub
Application.Calculation = xlCalculationManual
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("E6:G" & last_row).Clear
Set ObjReg = CreateObject("VBScript.RegExp")
With ObjReg
.Pattern = "(\W+)(\d+)[%-:,_](\W+)"
.Global = True
End With
For k = 6 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 = 5
    For i = 0 To a - 1
     Cells(k, col) = My_word.Submatches(i)
     col = col + 1
    Next
Next
End If
col = 5
Next
    With Range("E6:G" & last_row)
    .Borders.LineStyle = 1
    .Font.Size = 14
    .Font.Bold = True
    .InsertIndent 1
    .Columns.AutoFit
    .Interior.ColorIndex = 40
    End With
Set ObjReg = Nothing
Application.Calculation = xlCalculationAutomatic
End Sub

الملف مرفق

 

Extract Number.xlsm

[محمود محمود احمد]

اشكركم بارك الله فيكم وجعلة الله في ميزان حسناتكم