فصل محتوى الخلية إلى جزئين

[spyhearts]

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

كل عام وحضراتكم بخير

محتاج مساعدة في الملف المرفق فضلا وليس امرا

ولكم جزيل الشكر والتقدير

atf.xlsb

[Saleh Ahmed Rabie]

5 ساعات مضت, spyhearts said:

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

كل عام وحضراتكم بخير

محتاج مساعدة في الملف المرفق فضلا وليس امرا

ولكم جزيل الشكر والتقدير

atf.xlsb 68.31 kB · 6 downloads

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

**كود VBA لفصل محتوى الخلية إلى جزئين (الوصف والكود):**

Sub SplitCellContent()

    Dim rng As Range
    Dim arrContent() As String
    Dim strDescription As String
    Dim strCode As String

    ' تحديد الخلية التي تحتوي على المحتوى الذي تريد فصله
    Set rng = Range("A2")

    ' تقسيم المحتوى إلى مصفوفة من السلاسل
    arrContent = Split(rng.Value, " ")

    ' استخراج الوصف والكود من المصفوفة
    strDescription = arrContent(0)
    strCode = arrContent(1)

    ' وضع الوصف والكود في خلايا منفصلة
    rng.Offset(0, 1).Value = strDescription
    rng.Offset(0, 2).Value = strCode

End Sub

**مثال:**

إذا كان محتوى الخلية A2 هو:

جهاز كمبيوتر محمول HP EliteBook 840 G8

فسيؤدي تشغيل كود VBA هذا إلى فصل المحتوى إلى الخليتين B2 وC2 على النحو التالي:

* **B2:** جهاز كمبيوتر محمول HP EliteBook 840 G8
* **C2:** 840 G8

**ملاحظة:**

* يمكنك تعديل كود VBA لتناسب احتياجاتك الخاصة، مثل تغيير الخلية التي تحتوي على المحتوى أو تغيير الفاصل المستخدم لفصل الوصف والكود.
* يمكنك أيضًا استخدام كود VBA لفصل محتوى الخلية إلى أكثر من جزئين.

 

[spyhearts]

 

53 دقائق مضت, Saleh Ahmed Rabie said:

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

**كود VBA لفصل محتوى الخلية إلى جزئين (الوصف والكود):**

Sub SplitCellContent()

    Dim rng As Range
    Dim arrContent() As String
    Dim strDescription As String
    Dim strCode As String

    ' تحديد الخلية التي تحتوي على المحتوى الذي تريد فصله
    Set rng = Range("A2")

    ' تقسيم المحتوى إلى مصفوفة من السلاسل
    arrContent = Split(rng.Value, " ")

    ' استخراج الوصف والكود من المصفوفة
    strDescription = arrContent(0)
    strCode = arrContent(1)

    ' وضع الوصف والكود في خلايا منفصلة
    rng.Offset(0, 1).Value = strDescription
    rng.Offset(0, 2).Value = strCode

End Sub

**مثال:**

إذا كان محتوى الخلية A2 هو:

جهاز كمبيوتر محمول HP EliteBook 840 G8

فسيؤدي تشغيل كود VBA هذا إلى فصل المحتوى إلى الخليتين B2 وC2 على النحو التالي:

* **B2:** جهاز كمبيوتر محمول HP EliteBook 840 G8
* **C2:** 840 G8

**ملاحظة:**

* يمكنك تعديل كود VBA لتناسب احتياجاتك الخاصة، مثل تغيير الخلية التي تحتوي على المحتوى أو تغيير الفاصل المستخدم لفصل الوصف والكود.
* يمكنك أيضًا استخدام كود VBA لفصل محتوى الخلية إلى أكثر من جزئين.

 

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

مشكور ا. صالح ولكن لم يظبط معي الكود 

بانتظار المساعدة

[محمد هشام.]

هل هده هي النتيجة المتوقعة 

[spyhearts]

1 دقيقه مضت, محمد هشام. said:

هل هده هي النتيجة المتوقعة 

تمام ا. محمد

هذه هي النتيجة المطلوبة

[محمد هشام.]

ادن يمكنك استخدام الصيغ على النحو التالي 

' الوصف
=LEFT(A2,SEARCH("-",A2)-1)
'or
=LEFT(A2,FIND("-",A2)-1)

'الكود 
=MID(A2,FIND("-",A2)+1,LEN(A2))
'or
=RIGHT(A2,LEN(A2)-SEARCH("-",A2))
'or
=MID(A2,FIND("-",A2)+1,100)

 

مع سحب المعادلة للاسفل 

 

atf v2.xlsb

[spyhearts]

26 دقائق مضت, محمد هشام. said:

ادن يمكنك استخدام الصيغ على النحو التالي 

' الوصف
=LEFT(A2,SEARCH("-",A2)-1)
'or
=LEFT(A2,FIND("-",A2)-1)

'الكود 
=MID(A2,FIND("-",A2)+1,LEN(A2))
'or
=RIGHT(A2,LEN(A2)-SEARCH("-",A2))
'or
=MID(A2,FIND("-",A2)+1,100)

 

مع سحب المعادلة للاسفل 

 

atf v2.xlsb 72.99 kB · 0 downloads

شكرا ا. محمد مبدع كالعادة يعجز لساني عن كتابة وصف ومدح حضرتك في مساعدة الاعضاء يليق بافكار حضرتك عن تجربة شخصية في الحلول

هل يمكن فضلا من حضرتك وضعها كود برمجي

تم تعديل يونيو 22 بواسطه spyhearts
تعديل

[محمد هشام.]

بما انني غير متاكد من مكان وضع النتائج اليك اسهل طريقة لتتمكن من تعديلها على حسب احتياجاتك 

Sub ExtractFromText()
Dim lr&
Set ws = Sheets("ATIF")
Application.ScreenUpdating = False
ws.Range("b2:c" & ws.Rows.Count).ClearContents
lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
With ws.Range("B2:B" & lr)
  .Formula = "=LEFT(A2,FIND(""-"",A2)-1)"
     .Value = .Value
With ws.Range("C2:C" & lr)
  .Formula = "=MID(A2,FIND(""-"",A2)+1,LEN(A2))"
    .Value = .Value
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[spyhearts]

شكرا ا. محمد 

جزاك الله كل خير 

تم تشغيل الكود بنجاح 

شاكر جدا لحضرتك واتمني لحضرتك كل الخير 

من نجاح الى نجاح باذن الله 

[محمد هشام.]

48 دقائق مضت, spyhearts said:

تم تشغيل الكود بنجاح 

يسعدنا اننا استطعنا مساعدتك 

ادن اليك حل اخر في حالة عدم الرغبة باستخدام المعادلات 

 

Sub ExtractFromText2()
Dim arr() As String, Cell As Range, i As Integer, lr&
Set WS = Sheets("ATIF")

Application.ScreenUpdating = False
WS.Range("b2:C" & WS.Rows.Count).ClearContents
lr = WS.Cells(Rows.Count, "A").End(xlUp).Row
    
    For Each Cell In Range("A2:A" & lr)
    arr = Split(Trim(Cell), "-")
        If UBound(arr) <> 0 Then
            For i = 0 To UBound(arr)
            Cell.Offset(, i + 1) = arr(i)
            Next
        End If
    Next
    
   Application.ScreenUpdating = True
End Sub
'*********OR***********
Sub ExtractFromText3()
Dim r As Range, lr&
Set WS = Sheets("ATIF")
Application.ScreenUpdating = False
With WS
.Range("B2:C" & .Rows.Count).ClearContents
lr = .Cells(Rows.Count, "A").End(xlUp).Row
  For Each r In Range("A2:A" & lr)
        .Range(r.Offset(0, 1), r.Offset(0, 2)).Value = Split(r, "-")
       Next r
 End With
Application.ScreenUpdating = True
End Sub

 

تم تعديل يونيو 22 بواسطه محمد هشام.

[spyhearts]

34 دقائق مضت, محمد هشام. said:

يسعدنا اننا استطعنا مساعدتك 

ادن اليك حل اخر في حالة عدم الرغبة باستخدام المعادلات 

 

Sub ExtractFromText2()
Dim arr() As String, Cell As Range, i As Integer, lr&
Set WS = Sheets("ATIF")

Application.ScreenUpdating = False
WS.Range("b2:C" & WS.Rows.Count).ClearContents
lr = WS.Cells(Rows.Count, "A").End(xlUp).Row
    
    For Each Cell In Range("A2:A" & lr)
    arr = Split(Trim(Cell), "-")
        If UBound(arr) <> 0 Then
            For i = 0 To UBound(arr)
            Cell.Offset(, i + 1) = arr(i)
            Next
        End If
    Next
    
   Application.ScreenUpdating = True
End Sub
'*********OR***********
Sub ExtractFromText3()
Dim r As Range, lr&
Set WS = Sheets("ATIF")
Application.ScreenUpdating = False
With WS
.Range("B2:C" & .Rows.Count).ClearContents
lr = .Cells(Rows.Count, "A").End(xlUp).Row
  For Each r In Range("A2:A" & lr)
        .Range(r.Offset(0, 1), r.Offset(0, 2)).Value = Split(r, "-")
       Next r
 End With
Application.ScreenUpdating = True
End Sub

 

بارك الله فيك وزادك من علمه ا. محمد

تسلم ايديك