อยากได้โค๊ด VBA นำเข้าข้อความจาก Microsoft Word แบบหลาย ๆ ไฟล์มาลงใน Excel

[SuminO]

อยากได้โค๊ด VBA นำเข้าข้อความจาก Microsoft Word แบบหลาย ๆ ไฟล์มาลงใน Excel
โค๊ดที่ลงไว้สามารถนำเข้าได้แค่ไฟล์เเดียวครับ

Code: Select all

Sub extractData()

Dim wd As New Word.Application
Dim doc As Word.Document
Dim sh As Worksheet

wd.Visible = True

Set doc = wd.Documents.Open(ActiveWorkbook.Path & "\AUDIT ENGINE.docx")
Set tbls = doc.Tables
Set sh = ActiveSheet

lr = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1

For i = 1 To 10
    sh.Cells(lr, i).Value = Application.WorksheetFunction.Clean(tbls(1).Rows(i).Cells(2).Range.Text)
Next

For i = 1 To 156
    sh.Cells(lr, 10 + i).Value = Application.WorksheetFunction.Clean(tbls(2).Rows(i).Cells(2).Range.Text)
Next



doc.Close
wd.Quit
Set doc = Nothing
Set sh = Nothing
Set wd = Nothing


End Sub

[SuminO]

จากสูตร ผมอยากให้มันบันทึกข้อมูล เฉพราะ ตรงช่อง Texe Box ครับ

Code: Select all

Option Explicit

Sub ImportDOCX()
  Dim FName As String, FullName As String
  Dim wdApp As Object 'Word.Application
  Dim wdDoc As Object 'Word.Document
  Dim Coordinates As String, Contents As String
  Dim Dest As Range
  
  'Prepare
  Set Dest = Range("A2")
  Set wdApp = CreateObject("Word.Application")
  Application.ScreenUpdating = False
  
  'Find the first file
  FName = Dir(ThisWorkbook.Path & "\*.docx")
  'While found
  Do While FName <> ""
    'Full pathname
    FullName = ThisWorkbook.Path & "\" & FName
    'Open the file
    Set wdDoc = wdApp.Documents.Open(FullName, False, True)
    'First paragraph are the coordinates
    Coordinates = wdDoc.Paragraphs(1).Range.Text
    'Anything else from 3rd paragraph is the content
    Contents = wdDoc.Range(wdDoc.Paragraphs(3).Range.Start).Text
    'Close the file
    wdDoc.Close False
    
    'Write the name into the sheet and create a hyperlink for easy access
    With Dest
      .Value = FName
      .Hyperlinks.Add Dest, FullName
    End With
    'Write the data into this row
    Dest.Offset(, 1) = Coordinates
    Dest.Offset(, 2) = Contents
    
    'Next row
    Set Dest = Dest.Offset(1)
    'Next file
    FName = Dir
  Loop
  'Done
  Application.ScreenUpdating = True
  wdApp.Quit
End Sub

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Option Explicit

Sub ImportDOCX()
  Dim FName As String, FullName As String
  Dim wdApp As Object 'Word.Application
  Dim wdDoc As Object 'Word.Document
  Dim Coordinates As String, Contents As String
  Dim Dest As Range, a As Variant, i As Integer, j As Integer
  
  'Prepare
  Set Dest = Range("A2")
  Set wdApp = CreateObject("Word.Application")
  Application.ScreenUpdating = False
  
  'Find the first file
  FName = Dir(ThisWorkbook.Path & "\*.docx")
  'While found
  Do While FName <> ""
    'Full pathname
    FullName = ThisWorkbook.Path & "\" & FName
    'Open the file
    Set wdDoc = wdApp.Documents.Open(FullName, False, True)
    'First paragraph are the coordinates
    Coordinates = wdDoc.Paragraphs(1).Range.Text
    'Anything else from 3rd paragraph is the content
    Contents = wdDoc.Range(wdDoc.Paragraphs(3).Range.Start).Text
    'Close the file
    
    wdDoc.Close False
    
    'Write the name into the sheet and create a hyperlink for easy access
    With Dest
      .Value = FName
      .Hyperlinks.Add Dest, FullName
    End With
    'Write the data into this row
    Dest.Offset(, 1) = Coordinates
'    Dest.Offset(, 2) = Contents

    a = VBA.Split(Contents, Chr(7))
    For i = 0 To UBound(a)
        If (i + 1) Mod 3 = 0 Then
            Dest.Offset(0, 2 + j) = VBA.Trim(a(i))
            j = j + 1
        End If
    Next i
    'Next row
    Set Dest = Dest.Offset(1)
    'Next file
    FName = Dir
  Loop
  'Done
  Application.ScreenUpdating = True
  wdApp.Quit
End Sub

[SuminO]

ช่อง Name มาแต่หัวข้อครับ
และลำดับที่ 2 ไปเริ่มต้นที่ คอลัมถ์ L
รบกวนด้วยนะครับ

ผมรบกวนแปะเลขที่บัญชีไว้ให้ผมด้วยครับมีค่ากาแฟให้

[snasui]

ทำการกำหนดค่าตั้งต้นให้กับ j ใหม่ในแต่ละไฟล์ที่ Loop ครับ

ตัวอย่างการปรับ Code

Code: Select all

'Other code
    a = VBA.Split(Contents, Chr(7))
    j = 0
    For i = 0 To UBound(a)
    'Other code

ผมรบกวนแปะเลขที่บัญชีไว้ให้ผมด้วยครับมีค่ากาแฟให้

ขอบคุณสำหรับน้ำใจครับ การตอบในฟอรัมยินดีช่วยเหลือสมาชิกเพื่อการช่วยเหลือเผื่อแผ่ไม่ต้องเกรงใจครับ

[SuminO]

ขอบคุณอาจารย์ มาก ๆครับผม