ترحيل من الإكسل إلى وورد

[محمد مصطفى درويش]

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

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

علما ان الدخول عبر واجهة البرنامج بدون كلمة مرور اما كلمة المرور هي دارفشيان لاضافة مديول جديد بالضغط على Alt+ f11 

علما ان هذا البرنامج مجاني اخدم به الاف المعلمين من مدرسي الطلاب اللاجئين الفلسطينيين في الاردن 

موزع الطلاب الجدد للصف الأول2.xlsm

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

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

اللهم كن عونا وتصيرالاخواننا في فلسطين 

كان من المفترض ازالة الحماية من محرر الاكواد وحاولت بكلمة دارفشيان  فلم تنجح , على كل حال تم فتح محرر الاكواد بطريقتى الخاصة ولكن جميع الاكواد غير موجودة

ما يهمك الكود التالي انقله الى ملفك واربطه بزر

الكود

Sub ExportToWord1()
    Dim ws As Worksheet
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim lastRow As Long
    Dim fileName As String
    Dim filePath As String
    
    Set ws = ThisWorkbook.Sheets("قائمة الأسماء")
    
    fileName = ws.Range("E4").Value
    
    If fileName = "" Then
        MsgBox "اسم الملف في الخلية E4 فارغ. يرجى إدخال اسم الملف."
        Exit Sub
    End If
    
    fileName = Application.WorksheetFunction.Clean(fileName)
    fileName = Replace(fileName, "/", "")
    fileName = Replace(fileName, "\", "")
    fileName = Replace(fileName, ":", "")
    fileName = Replace(fileName, "*", "")
    fileName = Replace(fileName, "?", "")
    fileName = Replace(fileName, """", "")
    fileName = Replace(fileName, "<", "")
    fileName = Replace(fileName, ">", "")
    fileName = Replace(fileName, "|", "")
    
    fileName = fileName & ".docx"
    
    filePath = ThisWorkbook.Path
    
    On Error Resume Next
    Set wordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wordApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    
    wordApp.Visible = True
    
    Set wordDoc = wordApp.Documents.Add
    
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ws.Range("C1:E" & lastRow).Copy
    
    wordDoc.Content.Paste
    
    wordDoc.SaveAs2 filePath & "\" & fileName
    
    wordDoc.Close SaveChanges:=False
    
    wordApp.Quit
    
    Set wordDoc = Nothing
    Set wordApp = Nothing
    
    MsgBox "تم الترحيل بنجاح إلى الملف: " & fileName
End Sub

____________ __________ ________ __________2.xlsm

[محمد مصطفى درويش]

أستاذي عبدالله بشير عبدالله بارك الله فيك وفي مالك وجميع أحبابك الله يديمك 

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

 كم افرحنى واسعدنى دعاؤك لي ولك بالمثل اخونا الفاضل