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

[Al-Raadi]

السَلآْم عَلْيُكّمٌ وٍرٍحَمُةّ الله وٍبُرٍكآتُهْ

معي ملف ورد

اريد احوله الى اكسل

المهندسين والفنيين مدربين بالسلامة المهنية2.docx

تم تعديل يناير 28 بواسطه Al-Raadi

[mahmoud nasr alhasany]

Sub ImporterExcelPartirWord()
'Déclarez les variables Object pour l'application et le document Word.
Dim WordApp As Object, wddoc As Object
'Déclarez une variable String pour le nom du document d'exemple et le chemin du dossier.
Dim strDocNom As String
'L'instruction On Error si Word n'est pas déjà ouvert.
On Error Resume Next
'Activer Word s'il est déjà ouvert.
Set WordApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
'Créez une application Word si Word n'est pas déjà ouvert.
Set WordApp = CreateObject("Word.Application")
End If
'Assurez-vous que l'application Word est visible.
WordApp.Visible = True
'Définissez la variable de chaîne strDocName.
strDocNom = "C:\mesfichiers\monDocWord.docx"
'Activez l'application Word.
WordApp.Activate
'Définissez la variable objet pour le nom complet du document Word et le chemin d'accès au dossier.
Set worddoc = WordApp.Documents(strDocNom)
'Si le document Word n'est pas déjà ouvert, ouvrez-le.
If worddoc Is Nothing Then Set worddoc = WordApp.Documents.Open(strDocNom)
'Le document est ouvert, alors activez-le.
worddoc.Activate
'Copier le paragraphe 2
worddoc.Paragraphs(2).Range.Copy
'Activez votre classeur et collez le texte copié dans la cellule active.
ThisWorkbook.Activate
'Collez le paragraphe 2 du document Word.
ActiveSheet.Paste
'Fermez le document Word, pas besoin d'enregistrer les modifications.
worddoc.Close Savechanges:=False
'Quittez l'application Word.
WordApp.Quit
'Libérez la mémoire système réservée aux deux variables Object.
Set worddoc = Nothing
Set WordApp = Nothing
End Sub

 

[محمد هشام.]

Sub TEST1()
  Dim WordApp As Object, objDoc As Object, Fname As Variant
  Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word")
  WSdst.Cells.Clear
  Fname = Application.GetOpenFilename("Word Documents, *.doc*")
  If Fname = False Then Exit Sub
  On Error Resume Next
  Set WordApp = CreateObject("Word.Application")
  Set objDoc = WordApp.Documents.Open(Fname)
  WordApp.Selection.WholeStory
  WordApp.Selection.Copy
  WSdst.Range("A1").Select
  ActiveSheet.Paste
  With WSdst
    .Cells.EntireRow.AutoFit: .Columns("A:A").ColumnWidth = 15:  '<- قم بتنسيق الورقة بما يناسبك
    .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("B:E").ColumnWidth = 31
  End With
  objDoc.Close False
  WordApp.Quit
  Set WordApp = Nothing
  Set objDoc = Nothing
End Sub

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

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 WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word")

    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

     WSdst.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, 21, 22, 23, 24) '<- '<- ارقام الصفحات
            For Counter = LBound(tables) To UBound(tables)
                With .tables(tables(Counter))
                    For iRow = 1 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
 With WSdst
    .Cells.EntireRow.AutoFit: .Columns("A:b").AutoFit:  '<- قم بتنسيق الورقة بما يناسبك
    .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("c:e").ColumnWidth = 31
  End With
            Next Counter
            .Close False
        End With
    Next Filename
    WordApp.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing

End Sub

 

WORD.rar

تم تعديل يناير 29 بواسطه محمد هشام.
إضافة تحديد الصفحات