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

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ · يونيو 22, 2024

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

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

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

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

Saleh Ahmed Rabie · يونيو 22, 2024

في 22‏/6‏/2024 at 09:25, spyhearts said:

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

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

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

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

atf.xlsb 68.31 kB · 6 downloads

Expand

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

**كود 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 لفصل محتوى الخلية إلى أكثر من جزئين.

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ · يونيو 22, 2024

في 22‏/6‏/2024 at 14:54, 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 لفصل محتوى الخلية إلى أكثر من جزئين.
Expand

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

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

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

**محمد هشام.** · يونيو 22, 2024

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

img?id=853965

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ · يونيو 22, 2024

في 22‏/6‏/2024 at 15:53, محمد هشام. said:

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

Expand

تمام ا. محمد

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

**محمد هشام.** · يونيو 22, 2024

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

' الوصف
=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.xlsbFetching info...

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ · يونيو 22, 2024

في 22‏/6‏/2024 at 16:00, محمد هشام. 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
Expand

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

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

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

**محمد هشام.** · يونيو 22, 2024

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

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

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ · يونيو 22, 2024

شكرا ا. محمد

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

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

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

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

**محمد هشام.** · يونيو 22, 2024

في 22‏/6‏/2024 at 16:55, spyhearts said:

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

Expand

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

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

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, 2024 بواسطه محمد هشام.

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ · يونيو 22, 2024

في 22‏/6‏/2024 at 17:22, محمد هشام. 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

Expand

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

تسلم ايديك

تسجيل الدخول

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

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

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ

Saleh Ahmed Rabie

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ

محمد هشام.

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ

محمد هشام.

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ

محمد هشام.

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ

محمد هشام.

𝒜ℬ𝒪 𝒴𝒪𝒰𝒮ℰℱ

Join the conversation

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

تصفح الموقع

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

Support

Important Information