تحويل جدول على الوورد الى اكسل

[Alaa Ammar New]

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

إخواتي الكرام الاعزاء

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

مرفق الجدول المراد تحويله الى اكسل

انشطة جديد.docx

[MAHMOUD ALI YOUSSEF]

الشلام عليكم

جرب الملف المرفق

واخبرني رايك 

انشطة جديدة.xlsx

تم تعديل مايو 12 بواسطه MAHMOUD ALI YOUSSEF

[Alaa Ammar New]

السلام عليكم

سيدي الفاضل جزاك اله كل خير .. انا اريد الجدول على الاكيل بيحيث صف الوورد في الجدول ياخد صف واحد في الاكسل لكن الجدول بتاع حضرتك صف الوورد واخد اكثر من صف وانا عايز صف الوورد في صف اكسل واحد لان الدمج يضر الفلترة والبحث

[محمد هشام.]

Sub ImportWordTablesArray() 
    Dim tables() As Variant
    Dim WordApp As Object, WordDoc As Object
    Dim arrFile As Variant, Filename As Variant
    Dim Table As Integer, iCol As Integer
    Dim iRow As Long, Cpt As Long, Counter As Long
    Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("word")
    Dim ar(1 To 7)
    Dim c As Integer
    Dim cnt As Integer
    cnt = LBound(ar())
    ' قم بتعديل عرض الاعمدة بما يناسبك
    ar(1) = 10: ar(4) = 28: ar(7) = 85: ar(5) = 28: ar(6) = 35: ar(2) = 14: ar(3) = 68
    
    On Error Resume Next
    arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _
                                                  "اظافة الملف", , True)
    If Not IsArray(arrFile) Then Exit Sub
    Application.ScreenUpdating = False
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
     WS.Cells.Clear
    For Each Filename In arrFile
        Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True)
    With WordDoc
        Table = WordDoc.tables.Count
        If Table = 0 Then
            MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد"
        End If
           tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, _
          10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) '<- '<- ارقام الصفحات
            
            For Counter = LBound(tables) To UBound(tables)
                With .tables(tables(Counter))
                    For iRow = 0 To .Rows.Count
                        For iCol = 0 To .Columns.Count
                            Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                        Next iCol
                        Cpt = Cpt + 1
                    Next iRow
                End With
                Cpt = Cpt + 1
                
            Next Counter
            .Close False
        End With
    Next Filename
    WordApp.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
lr = WS.Columns("A:G").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1
For Each j In WS.Range("G2:G" & lr)
  WS.Hyperlinks.Add j, j
Next j
WS.Rows(1).Interior.ColorIndex = 45
For cnt = LBound(ar()) To UBound(ar())
    Columns(cnt).ColumnWidth = ar(cnt)
Next cnt
 Set rngCell = WS.Range("A1 :g" & lr)
    For Each k In rngCell.Rows
   If WorksheetFunction.CountA(k) > 0 Then k.Borders.ColorIndex = 5 'c.Borders.LineStyle = xlContinuous
Next
With WS.Range("a2:a" & WS.Cells(Rows.Count, "b").End(xlUp).Row)
    .Value = Evaluate("ROW(" & .Address & ")-1")
    End With
End Sub

https://streamable.com/xdlk5v

 

 

 

 

TEST WORD.rar

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

[Alaa Ammar New]

أستاذي الفاضل @محمد هشام. جزاك الله كل خير برنامج اكثر من رائع فعلا هو بس بيطلعلي في الآخر رسالة خطا انا ارفقتها في المرفقات لتطلع عليها ,كمان انا مش عارف هو بيحفظ الملف النهائي بعد التعديل فين فهل ممكن تخليه يحفظ في نفس المجلد اللي انا حاطط في الملف الوورد؟ أكون شاكر جدا لسيادتكم وأكرر فعلا برنامج اكثر من رائغ جزاء الله كل خير سيدي الكريم

[محمد هشام.]

جرب هذا سيتم نسخ الملف الى مصنف جديد   بصيغة  xlsx . في نفس مسار المصنف المفتوح 

 

 

 

TEST WORD 2.rar

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