ضم الاعمدة بترتيب معين في شيت جديد وتخزين بصيغة csv

[saffar]

السلام عليكم

مقدمة :
يتم تحويل الاسماء من الاكسل الى الهاتف النقال لاستخدامها في عمل مجموعات للواتس اب بترتيب معين (لتمييز الطالب في اي صف ورقم الوالد او الوالدة) بشكل دوري كل سنة دراسية 

مثال :
العمود A (الصف + حرف (F) + اسم الطالب) العمود B (رقم نقال الوالد)

العمود A (الصف + حرف (M) + اسم الطالب) العمود B (رقم نقال الوالدة)

10A (F) Ahmed Kamal
10A (M) Ahmed Kamal

 

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

المطلوب :
ضم الاسماء بالشكل الذي في المثال في شيت جديد

تخزين الملف بصيغة  CSV

او هل في طريقة او اقتراح اسرع لتحول الاسماء بالشكل المطلوب الى الهاتف 

Example.xlsx

[محي الدين ابو البشر]

ضم الاسماء بالشكل الذي في المثال في شيت جديد

تخزين الملف بصيغة  CSV

Sub test()
    Dim a As Variant
    Dim nm As String
    Dim i As Long
    a = Sheets("sheet1").Cells(1, 1).CurrentRegion.Offset(1)
    For i = 1 To UBound(a) - 1
        nm = a(i, 2)
        a(i, 2) = nm & " (" & "F" & ") " & a(i, 1)
        a(i, 3) = nm & " (" & "M" & ") " & a(i, 1)
    Next
    With Sheets("Output").Cells(2, 1)
        .Offset(-1) = "Name": .Offset(-1, 1) = "Mobile"
        .Resize(UBound(a) - 1, 2) = Application.Index(a, Evaluate("row(1:" & UBound(a, 1) & ")"), Array(2, 4))
        .Offset(UBound(a) - 1).Resize(UBound(a), 2) = Application.Index(a, Evaluate("row(1:" & UBound(a, 1) & ")"), Array(3, 5))
    End With
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("Output").Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "NAMEPHONE", FileFormat:=xlCSV, CreateBackup:=True
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
End Sub

يحفظ الـ CSV

في نفس المسار

[saffar]

سلمت يداك استاذ محي الدين

من ضمن الاسئلة اذا في امكانية تحويلهم الى برنامج Outlook

شكرا مره ثانية