การคัดลอกข้อมูลจากเอกสารคำหลายคำลงในแผ่นงาน excel เดียว

ฉันมีไฟล์ doc และ docx ประมาณ 4,000 ไฟล์ซึ่งมีตาราง ฉันจัดการเพื่อนำเข้าสิ่งเหล่านี้ลงในแผ่นงาน excel โดยใช้สคริปต์ต่อไปนี้:

Sub Macro1()
   Dim xl As Object
   Set xl = CreateObject("excel.application")

   xl.workbooks.Add
   xl.Visible = True

   'Here put your path where you have your documents to read:
   myPath = "C:\Users\"  'End with '\'
   myFile = Dir(myPath & "*.docx")

   xlRow = 1
   Do While myFile <> ""
      Documents.Open FileName:=myPath & myFile, ConfirmConversions:=False, _
         ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
         PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
         WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""

      xlCol = 0
      For Each t In ActiveDocument.Tables
         For Each r In t.Rows
            For Each c In r.Range.Cells
               myText = c
               myText = Replace(myText, Chr(13), "")
               myText = Replace(myText, Chr(7), "")
               xlCol = xlCol + 1
               xl.activeworkbook.activesheet.Cells(xlRow, xlCol) = myText

            Next c
            xlRow = xlRow + 1
            xlCol = 0
         Next r
      Next t
      ActiveWindow.Close False

      myFile = Dir
   Loop

   xl.Visible = True
End Sub

ปัญหาเดียวก็คือว่านอกตารางของเอกสารคือวันที่ เนื่องจากนี่ไม่ได้อยู่ในตารางจึงไม่หยิบมาและฉันมีรายการข้อมูลจำนวนมากที่ไม่มีวันที่ ฉันจะทำให้การนำเข้าข้อมูลทั้งหมดหรืออย่างน้อยวันที่ลงในแผ่นงาน excel ได้อย่างไร หากไม่มีวันที่ข้อมูลที่ฉันได้จะอยู่ในลำดับใด ๆ และไร้ประโยชน์กับฉัน

ความคิดเห็นของคุณระบุว่าชื่อไฟล์มีวันที่ที่คุณต้องการ คุณกำลังเข้าถึงชื่อไฟล์ในตัวแปร myFile ทำไมไม่ตัดมันออกเพื่อให้ได้วันที่และใส่มันที่ไหนที่คุณต้องการ คุณสามารถทำให้มันเป็นเซลล์แรกหรือเซลล์สุดท้ายในตารางปลายทางตัวอย่างเช่น

ตัวอย่างที่เพิ่ม:

ลองเพิ่มแถวใหม่นี้ในสคริปต์ของคุณ

        Next c
        'new
        xl.activeworkbook.activesheet.Cells(xlRow, xlCol + 1) = myFile
        xlRow = xlRow + 1