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

samycalls2020 · الأحد at 09:25

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

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

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

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

**أبوعيد** · الأحد at 14:12

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

تفضل

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

samycalls2020 · الأحد at 14:38

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

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

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

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

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

**أبوعيد** · الأحد at 15:39

اهلا بك

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

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

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

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

تفضل

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

samycalls2020 · الأحد at 15:53

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

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

**أبوعيد** · الأحد at 19:16

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

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

تفضل

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

samycalls2020 · الأحد at 20:53

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

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

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

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

**محمد هشام.** · الأحد at 21:14

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

جرب هدا

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 · الأحد at 22:56

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

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

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

**محمد هشام.** · الإثنين at 01:41

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

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

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 · الإثنين at 09:56

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

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

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

 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

**محمد هشام.** · الإثنين at 21:04

جرب هل هدا ما تقصده

Option Explicit
Sub Split_names()
    Dim tbl&, tmp&, i&, Max&, c&, j&, lr&, r&, s&
    Dim n As String, ky As Boolean, ColArr As Range, OnRng As Range
    Dim Arr As Variant, rng As Variant, sp As Variant, Choisir As VbMsgBoxResult

    Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد")
    Dim dest As Worksheet: Set dest = Sheets("مؤشر الفائدة")
    Dim ColNam As String: ColNam = "DM"
    
    Choisir = MsgBox("تحديث البيانات ؟", vbYesNo + vbQuestion, "تأكيد")
    If Choisir <> vbYes Then Exit Sub
    
    Max = 444

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

    On Error Resume Next
    tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    On Error GoTo 0

    tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max)

    WS.Range("DJ14:DJ" & tbl).ClearContents

    Set OnRng = WS.Range("T14:CC" & tbl)
    Arr = OnRng.Value

    For tmp = 1 To UBound(Arr, 1)
        n = ""
        ky = False
        For i = 1 To UBound(Arr, 2)
            If Arr(tmp, i) <> "" Then
                n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text)
                If Not ky Then
                    WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat
                    ky = True
                End If
            End If
        Next i
        WS.Cells(tmp + 13, 114).Value = n
    Next tmp

    On Error Resume Next
    Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not ColArr Is Nothing Then
        Arr = ColArr.Value
        ReDim rng(1 To UBound(Arr, 1), 1 To 1)
        For c = 1 To UBound(Arr, 1)
            rng(c, 1) = Arr(c, 1)
        Next c
        WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng
    End If

    dest.Range("AS2") = 2
    dest.Range("I6:AL105").ClearContents

    lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row
    WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents

    Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value

    For j = 1 To UBound(Arr, 1)
        sp = Split(Arr(j, 1), "*")
        For r = LBound(sp) To UBound(sp)
            WS.Cells(j + 13, r + 118).NumberFormat = "@"
            WS.Cells(j + 13, r + 118).Value = sp(r)
        Next r
    Next j

    For s = 9 To 38
        dest.Columns(s).EntireColumn.Hidden = (dest.Cells(5, s).Value = 0)
    Next s

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

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

samycalls2020 · الثلاثاء at 15:04

أحسنت أ. هشام .. كود ممتاز

وليناسب الملف لدى قمت بإضافة بسيطة

أشكرك وبارك الله فيكم

Sub Split_names()
    Dim tbl&, tmp&, i&, Max&, c&, j&, lr&, r&, s&
    Dim n As String, ky As Boolean, ColArr As Range, OnRng As Range
    Dim Arr As Variant, rng As Variant, sp As Variant

    Dim WS As Worksheet: Set WS = Sheets("حساب الفوائد")
    Dim dest As Worksheet: Set dest = Sheets("مؤشر الفائدة")
    Dim ColNam As String: ColNam = "DM"
  
    Max = 444

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

    On Error Resume Next
    tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    On Error GoTo 0

    tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max)

    WS.Range("DJ14:DJ" & tbl).ClearContents

    Set OnRng = WS.Range("T14:CC" & tbl)
    Arr = OnRng.Value

    For tmp = 1 To UBound(Arr, 1)
        n = ""
        ky = False
        For i = 1 To UBound(Arr, 2)
            If Arr(tmp, i) <> "" Then
                n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text)
                If Not ky Then
                    WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat
                    ky = True
                End If
            End If
        Next i
        WS.Cells(tmp + 13, 114).Value = n
    Next tmp

    On Error Resume Next
    Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not ColArr Is Nothing Then
        Arr = ColArr.Value
        ReDim rng(1 To UBound(Arr, 1), 1 To 1)
        For c = 1 To UBound(Arr, 1)
            rng(c, 1) = Arr(c, 1)
        Next c
        WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng
    End If

    dest.Range("AS2") = 2
    dest.Range("I6:AL105").ClearContents

    lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row
    WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents

    Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value

    For j = 1 To UBound(Arr, 1)
        sp = Split(Arr(j, 1), "*")
        For r = LBound(sp) To UBound(sp)
            WS.Cells(j + 13, r + 118).NumberFormat = "@"
            WS.Cells(j + 13, r + 118).Value = sp(r)
        Next r
    Next j

    For s = 9 To 38
        dest.Columns(s).EntireColumn.Hidden = (dest.Cells(5, s).Value = 0)
    Next s

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .ErrorCheckingOptions.BackgroundChecking = False
    End With
    Sheets("حساب الفوائد").Range("DN14:EQ113").SpecialCells(xlCellTypeVisible).Copy
 Sheets("مؤشر الفائدة").Range("I6:AL105").PasteSpecial xlPasteValues
  Range("I5").Select
  
   'لإخفاء الأعمده الفارغة
    For s = 9 To 38
     If Cells(5, s).Value = "" Then
Columns(s).EntireColumn.Hidden = True
Else
Columns(s).EntireColumn.Hidden = False
End If
Next s
 Application.ScreenUpdating = False
  'إحتواء منسب الأعمده
For s = 9 To 38
Columns(s).AutoFit
Next s
End Sub

تم تعديل الثلاثاء at 15:11 بواسطه samycalls2020

**محمد هشام.** · الثلاثاء at 19:37

Sub Split_names()
    Dim WS As Worksheet, dest As Worksheet
    Dim tbl&, Max&, lr&, tmp&, i&, c&, j&, r&, s&, n As String, ky As Boolean
    Dim ColArr As Range, OnRng As Range, Arr As Variant, rng As Variant, sp As Variant
    
    Dim ColNam As String: ColNam = "DM"
    
    Set WS = Sheets("حساب الفوائد")
    Set dest = Sheets("مؤشر الفائدة")
    
    Max = 444
    
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .ErrorCheckingOptions.BackgroundChecking = True
    End With

    
    On Error Resume Next
    tbl = WS.Columns("T:CC").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    On Error GoTo 0
    tbl = WorksheetFunction.Min(WorksheetFunction.Max(tbl, 14), Max)
    
    WS.Range("DJ14:DJ" & tbl).ClearContents
    Set OnRng = WS.Range("T14:CC" & tbl)
    Arr = OnRng.Value
    
    For tmp = 1 To UBound(Arr, 1)
        n = ""
        ky = False
        For i = 1 To UBound(Arr, 2)
            If Arr(tmp, i) <> "" Then
                n = IIf(n = "", WS.Cells(dest.Range("AT6").Value, i + 19).Text, n & "*" & WS.Cells(dest.Range("AT6").Value, i + 19).Text)
                If Not ky Then
                    WS.Cells(tmp + 13, 114).NumberFormat = WS.Cells(tmp + 13, i + 19).NumberFormat
                    ky = True
                End If
            End If
        Next i
        WS.Cells(tmp + 13, 114).Value = n
    Next tmp
    
    On Error Resume Next
    Set ColArr = WS.Range("DG14:DG" & tbl).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not ColArr Is Nothing Then
        Arr = ColArr.Value
        ReDim rng(1 To UBound(Arr, 1), 1 To 1)
        For c = 1 To UBound(Arr, 1)
            rng(c, 1) = Arr(c, 1)
        Next c
        WS.Range("DM14").Resize(UBound(rng, 1), 1).Value = rng
    End If
    
    dest.Range("AS2") = 2
    dest.Range("I6:AL105").ClearContents
    
    lr = WS.Cells(WS.Rows.Count, ColNam).End(xlUp).Row
    WS.Range("DN14:EQ" & WS.Rows.Count).ClearContents
    
    Arr = WS.Range(ColNam & "14:" & ColNam & lr).Value
    For j = 1 To UBound(Arr, 1)
        sp = Split(Arr(j, 1), "*")
        For r = LBound(sp) To UBound(sp)
            WS.Cells(j + 13, r + 118).NumberFormat = "@"
            WS.Cells(j + 13, r + 118).Value = sp(r)
        Next r
    Next j
    
    ColonnesVides dest, 9, 38
    
    WS.Range("DN14:EQ113").SpecialCells(xlCellTypeVisible).Copy
    dest.Range("I6:AL105").PasteSpecial xlPasteValues
    
    AutoFitColumns dest, 9, 38
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .ErrorCheckingOptions.BackgroundChecking = False
    End With
End Sub
Sub ColonnesVides(sh As Worksheet, début As Integer, FinCol As Integer)
    Dim s As Integer
    For s = début To FinCol
        sh.Columns(s).EntireColumn.Hidden = (sh.Cells(5, s).Value = "")
    Next s
End Sub
Sub AutoFitColumns(sh As Worksheet, début As Integer, FinCol As Integer)
    Dim s As Integer
    For s = début To FinCol
        sh.Columns(s).AutoFit
    Next s
End Sub

بالتوفيق.............

تسجيل الدخول

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

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

samycalls2020

أبوعيد

samycalls2020

أبوعيد

samycalls2020

أبوعيد

samycalls2020

محمد هشام.

samycalls2020

محمد هشام.

samycalls2020

محمد هشام.

samycalls2020

محمد هشام.

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information