استخراج أسماء أو قيم

[samycalls2020]

السلام عليكم .. هذا جدول أود استخراج الأسماء أو القيم منه بمعادلة كما هو موضح

والشكر لكم مقدماً

 

DATA.xlsx

تم تعديل فبراير 1 بواسطه samycalls2020

[عبدالله بشير عبدالله]

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

 

الحل بطريقتان

اولا الكود 

Sub FillNamesInColumnN()
    Dim ws As Worksheet, lastRow As Long, rowIndex As Long, colIndex As Long, names As String

    Set ws = ThisWorkbook.Sheets("ورقة1")
    
    For colIndex = 2 To 13
        lastRow = Application.Max(lastRow, ws.Cells(ws.Rows.Count, colIndex).End(xlUp).Row)
    Next colIndex

    For rowIndex = 6 To lastRow
        names = ""
        For colIndex = 2 To 13
            If ws.Cells(rowIndex, colIndex).Value <> "" Then
                names = names & IIf(names = "", "", " - ") & ws.Cells(5, colIndex).Value
            End If
        Next colIndex
        ws.Cells(rowIndex, 14).Value = names
    Next rowIndex

    MsgBox "تمت العملية !", vbInformation
End Sub

الثاني بالمعادلات

=TRIM(IF(B8<>"";B$5;"") & IF(C8<>"";"- " & C$5;"") & IF(D8<>"";" - " & D$5;"") & IF(E8<>"";" - " & E$5;"") & IF(F8<>"";" - " & F$5;"") & IF(G8<>"";" - " & G$5;"") & IF(H8<>"";" - " & H$5;"") & IF(I8<>"";" - " & I$5;"") & IF(J8<>"";" - " & J$5;"") & IF(K8<>"";" - " & K$5;"") & IF(L8<>"";" - " & L$5;"") & IF(M8<>"";" - " & M$5;""))

المعادلة طويلة ربما يكون اصدار الاكسل لديكم قديم فالكود او المعادلة تتماشى مع الاصدارات القديمة وكذلك الحديثة

الملف وبه الطريقتان

DATA1.xls

 

تم تعديل فبراير 1 بواسطه عبدالله بشير عبدالله

[samycalls2020]

الحل بالكود ممتاز أخى الكريم .. عبد الله

ولكن لو أردت أن يكون الحل على صف3 أو صف4 بدل صف 5 ..  كما فى المرفق فما هو التعديل للكود 

DATA2.xlsb

[عبدالله بشير عبدالله]

 اذا اردت الاسماء قي الصف الثالث

2 ساعات مضت, عبدالله بشير عبدالله said:

                names = names & IIf(names = "", "", " - ") & ws.Cells(5, colIndex).Value

بدل 5 الى3

ثم عدل في السطر

2 ساعات مضت, عبدالله بشير عبدالله said:

    For rowIndex = 6 To lastRow

بدل 6  الى 4  

اما اذا اردت  الصف الرابع بدل 5 الى4  وبدل 6 الى 5

اتمنى ات يكون الامر واضح 

تحياتي

[samycalls2020]

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

لاحظت الحل فى هذا السطر

names = names & IIf(names = "", "", " - ") & ws.Cells(5, colIndex).Value

يغير رقم 5 إلى رقم الصف المطلوب

[عبدالله بشير عبدالله]

تعم   بالظبظ

ولكن عند تغييرك الى الصف المطلوب ولتفرض الصف3 

فتكون بداية البيانات الصف4 

وعليه يجب التعديل في السطر بدل 6 الى 4

For rowIndex = 6 To lastRow

 

تم تعديل فبراير 2 بواسطه عبدالله بشير عبدالله

[samycalls2020]

الشكر والعرفان لك أ.عبدالله بشير

[samycalls2020]

معذرة للعوده فى هذا الأمر

الأستاذ الكريم عبد الله بشير .. السلام عليكم

صادفنى هذا الأمر فى التنفيذ على الملف الأصلى

فهل من الممكن أن يقوم الكود بالإستخراج بنفس تنسيق مصدره ولا أقصد هنا لون الخط أو نوعه أو لون الخليه

ولكن أقصد مثل التاريخ شهر وسنه ومثل النسبة المئوية والرقم بالعلامة من مئة وهكذا .. نفس تنسيق المصدر

DATA3.xlsb

تم تعديل فبراير 14 بواسطه samycalls2020

[AbuuAhmed]

بإذن الأستاذ عبدالله
ضع سجل البداية في متغير يحميك من الأخطاء:
 

firstRow = 5	'السجل المطلوب
For rowIndex = firstRow + 1 To lastRow
	names = ""
   	For colIndex = 2 To 13
   		If ws.Cells(rowIndex, colIndex).Value <> "" Then
         	names = names & IIf(names = "", "", " - ") & ws.Cells(firstRow, colIndex).Value
   		End If
  	Next colIndex
   	ws.Cells(rowIndex, 14).Value = names
Next rowIndex

 

[samycalls2020]

أ. أبو أحمد .. سلام الله عليك .. قمت بالتطبيق ولكنها أعطت نفس النتيجة

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

[AbuuAhmed]

جرب هذه المحاولة بعد الإضافة على كود الأستاذ عبدالله حسب طلبك الأخير.

DATA_05.xlsb

[AbuuAhmed]

أضف في آخر الكود هذا السطر:
 

   Set ws = Nothing

 

[محمد هشام.]

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

بطريقة أخرى 

Option Explicit
Sub test()
    Dim WS As Worksheet, tbl As Long, tmp As Long, i As Long
    Dim n As String, Max As Long, ky As Boolean
    Max = 34
    Set WS = Sheets("ورقة1")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    On Error Resume Next
    tbl = WS.Columns("B:M").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    On Error GoTo 0

    tbl = IIf(tbl = 0, 6, tbl)
    tbl = IIf(tbl > Max, Max, tbl)
    
    WS.Range("N6:N" & tbl).ClearContents

    For tmp = 6 To tbl
        n = ""
        ky = False
        
        For i = 2 To 13
            If WS.Cells(tmp, i).Value <> "" Then
                n = IIf(n = "", WS.Cells(5, i).Text, n & " - " & WS.Cells(5, i).Text)
                If Not ky Then
                    WS.Cells(tmp, 14).NumberFormat = WS.Cells(tmp, i).NumberFormat
                    ky = True
                End If
            End If
        Next i
        
        WS.Cells(tmp, 14).Value = n
    Next tmp
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

 

DATA V1.xlsb

تم تعديل فبراير 15 بواسطه محمد هشام.

[samycalls2020]

الشكر كل الشكر لكل من شارك وتعب وبذل جهداً

كل الحلول كانت جيدة ولكن للأمانه ما تطابق مع ما أريده بدقة هو الحل الذى قدمه الأستاذ محمد هشام

شكراً أ. عبد الله بشير أ. أبى أحمد وأ. محمد هشام

[AbuuAhmed]

1 ساعه مضت, samycalls2020 said:

كل الحلول كانت جيدة ولكن للأمانه ما تطابق مع ما أريده بدقة هو الحل الذى قدمه الأستاذ محمد هشام

كلام غير دقيق، نعم في شفرتي هناك مشكلة واحدة لاختلاف في دالة التنسيق بين الإكسل والبيزك، ففي الإكسل "General" تكون في الأكسس "General Number"
وهذا سبب بخطأ واحد فقط لرقم 52 والحل إما بعمل تبديل التنسيق للخلية أو تبديله في الشفرة أو نأخذ قيمة Text بدلا من Value للخلية المصدر.

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

لا يهمني اختيار جوابي كما فعلت ولا يعني ملاحظتي لك التقليل من جهد أساتذتي فإن أمكنك إعطاء الاختيار لأحد أساتذتي فافعل. 

تم تعديل فبراير 15 بواسطه AbuuAhmed

[samycalls2020]

لم أقصد الإساءه لأحد والله أعلم بالنوايا .. وأعود وأكرر الشكر للجميع

تم تعديل فبراير 16 بواسطه samycalls2020

[AbuuAhmed]

أزلت تعليقي فلا فائدة من كثرة الكلام.

تم تعديل الإثنين at 00:10 بواسطه AbuuAhmed

[AbuuAhmed]

نسخة أخيرة منقحة.
 

Sub GetNames()
    Dim Row As Long, lastRow As Long, firstRow As Byte, valueRow As Byte
    Dim Col As Integer, lastCol As Integer, firstCol As Byte, Names As String
    
    Application.ScreenUpdating = False
    Sheets("ورقة1").Select
    
    '------------------ التحديد اليدوي ----------------
    valueRow = 4    'سطر البيانات المطلوبة
    firstRow = 6    'أول سطر في الجدول
    firstCol = Range("B1").Column   'أول عمود في الجدول
    lastCol = Range("M1").Column    'آخر عمود في الجدول
    '--------------------------------------------------
    lastRow = Cells(1, 1).SpecialCells(xlLastCell).Row
    
    For Row = firstRow To lastRow
        Names = ""
        For Col = firstCol To lastCol
            If Cells(Row, Col) <> "" Then
                Names = Names & IIf(Names = "", "", " - ") & Cells(valueRow, Col).Text
            End If
        Next Col
        Cells(Row, lastCol + 1) = Names
    Next Row
    
    Application.ScreenUpdating = True
    MsgBox "تم", vbInformation, "جلب الأسماء"
End Sub

 

 

 

DATA_07.xlsb

تم تعديل الإثنين at 00:05 بواسطه AbuuAhmed