فصل أسماء وأرقام

[samycalls2020]

السلام عليكم اخوتى فى الله

كل عام وأنتم بخير .. رمضان كريم

أود من فضلكم التعديل فى الكود المخصص للورقة الأولى ليحقق المطلوب كما هو موضح بالورقة الثانية

فصل كلمات وأرقام.xlsb

[أبوعيد]

تم عمل المطلوب بالمعادلات مع وجود اقتراح منى داخل الملف

تفضل

1فصل كلمات وأرقام.xlsb

[samycalls2020]

مشكور أ. أبوعيد ..وأقتراحك محل تقدير 

ولكن الملف به مئات ومئات الأسطر وتم تحريره على هذا الوضع وبه الكثير من المعادلات بالأوراق الأخرى وهو ملف ثقيل

وهذه المعادلات التى طرحتها مشكورا موجوده لدى

وهناك حل أخر من خلال (تبويب) بيانات وهو النص إلى أعمده , وهو حل سريع وخفيف ولكن مشكلته عدم تطابق التنسيق

فأرجو تعديل الماكروا الموجود بالورقه الأولى إن أمكن ذلك

[أبوعيد]

اهلا بك

تم أضافة سطر للكود في الورقة1 

الكود يعمل كما هو ولم أغير فيه شيء الا اضافة سطر المسح

ولكن التغيير في كيفية كتابة الأسماء كما يوجد داخل الملف 

لاحظ الخلايا الصفراء هي اسماء مركبة تم كتابتها بشكل خاص حتى يتعرف عليها الكود

تفضل

2فصل كلمات وأرقام.xlsb

[samycalls2020]

اساذنا الغالى الملف الأصلى محرر بالطريقة المذكورة فى ورقة 2

أود تعديل الكود ليتعامل مع وضع الملف الحالى .. لو تكرمت

[أبوعيد]

السطر الأخضر الموجود فيه الأرقام 1 2 3 4 ..... مهم جدا , لو تم تغيير الأرقام ستختلف النتائج

اضغط على فصل2 ولاحظ النتيجة

تفضل

3صل كلمات وأرقام.xlsb

[samycalls2020]

مجهود رائع أ. أبو عيد بارك الله لك

ولكن هناك ملحوظتان إن سمحت لى

1- الاسم الأخير أو الرقم الأخير فى كل صف لايظهر 

2- الأرقام التى هى أقل من الألف لاتظهر بها العلامة العشرية مثل 312 فالمراد أن تظهر 312.00 كما فى الصف 3 والصف 7

 

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

جرب هدا

Option Explicit
Sub Split_names()
    Dim sp As Variant, j&, lr&, i&
    Dim WS As Worksheet: Set WS = ActiveSheet
    
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual
        .ErrorCheckingOptions.BackgroundChecking = True
    End With
    
    lr = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
    WS.Range("C14:AF" & lr).ClearContents

    For j = 14 To lr
        sp = Split(WS.Cells(j, "B").Value2, "*")
        For i = LBound(sp) To UBound(sp)
            WS.Cells(j, i + 3).NumberFormat = "@"
            WS.Cells(j, i + 3).Value = sp(i)
        Next i
    Next j
    
    With Application
        .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
        .ErrorCheckingOptions.BackgroundChecking = False
    End With
End Sub

 

فصل كلمات وأرقام v2.xlsb

[samycalls2020]

أستاذنا الغالى محمد هشام الكود ممتاز

عند تطبيقة على الملف الأصلى ظهرت هذه الرسالة

والصورة الأخرى قد تكون لها علاقة أو أنها تتعارض مع الأولى عندما اضفت الكود 

[محمد هشام.]

ليس لي فكرة عما تحاول فعله بالظبط لاكن اليك الكود مرة أخرى بعد تعديل أسماء  الأعمدة المستهدفة  بما يتناسب مع شكل الملف الأصلي إعتمادا على الصورة المرفقة 

حاول تجربته ووافينا بالنتيجة 

Option Explicit
Sub test()
    Dim sp As Variant, j As Long, lr As Long, i As Long
    Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد")
    Dim ColNam As String: ColNam = "DM"
    Dim destCol As String: destCol = "DN"

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .ErrorCheckingOptions.BackgroundChecking = True
    End With

    On Error GoTo CleanUp

    lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row

    If lr >= 14 Then
        WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents
        For j = 14 To lr
            If Not IsEmpty(WS.Cells(j, ColNam).Value) Then
                sp = Split(WS.Cells(j, ColNam).Value2, "*")
                For i = LBound(sp) To UBound(sp)
                    WS.Range(destCol & j).Offset(0, i).NumberFormat = "@"
                    WS.Range(destCol & j).Offset(0, i).Value = sp(i)
                Next i
            End If
        Next j
    End If

CleanUp:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .ErrorCheckingOptions.BackgroundChecking = False
    End With
End Sub

 

 

فصل كلمات وأرقام v3.xlsb

[samycalls2020]

أ. محمد هشام .. أنا أسف لتعبك معايا .. لك كل التقدير

لم أجد بد غير وضع الملف الأصلى بعد إجراء بعض التغيرات

الكود بالملف ممتاز وهو كودك بالأساس وهناك جزء فى الكود قمت أنا بعمله يعطى نتيجه جيده ولكن به بعض الملاحظات .. لذلك أود تغيره بكودك المتقن وهو موجود باللون الأخضر وحاولت تشغيله ولكن كانت المشكلة التى أسلت لك صورتها

 

 Option Explicit
Sub Split_names()
    Dim sp As Variant, j&, lr&, i&
    Dim WS As Worksheet: Set WS = ActiveSheet
    
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual
        .ErrorCheckingOptions.BackgroundChecking = True
    End With
    
    lr = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
    WS.Range("C14:AF" & lr).ClearContents

    For j = 14 To lr
        sp = Split(WS.Cells(j, "B").Value2, "*")
        For i = LBound(sp) To UBound(sp)
            WS.Cells(j, i + 3).NumberFormat = "@"
            WS.Cells(j, i + 3).Value = sp(i)
        Next i
    Next j
    
    With Application
        .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
        .ErrorCheckingOptions.BackgroundChecking = False
    End With
End Sub

 

نسب ومؤشر الفائدة222.xlsb