This is my code. The code run with 3000 file word in Foldername-folder:
Option Explicit
Sub GetDoc_Properties()
Dim FolderName As String, wbName As String
Dim rw As Integer
Dim lrow As Long, lrow2 As Long
Dim ObjWord As Object
Dim DoSubj As String, DoTit As String, DoAut As String
Dim sDate
On Error Resume Next
lrow = ActiveSheet.Range("B65000").End(xlUp).Row
ActiveSheet.Range("A9:G" & lrow + 9).ClearContents
FolderName = Cells(4, 5)
wbName = Dir(FolderName & "\" & "*.doc")
Application.ScreenUpdating = False
rw = 9
Set ObjWord = CreateObject("Word.Application")
While wbName < ""
With ObjWord
.Visible = True
.Documents.Open (FolderName & "\" & wbName)
DoSubj = .ActiveDocument.BuiltinDocumentProperties(2)
DoTit = .ActiveDocument.BuiltinDocumentProperties(1)
DoAut = .ActiveDocument.BuiltinDocumentProperties(3)
.Documents(wbName).Close
End With
Cells(rw, 1) = rw - 8
Cells(rw, 2).Value = DateSerial(2008, Mid(wbName, 4, 2), Mid(wbName, 1,
2))
Cells(rw, 3).Value = Mid(wbName, 7, Len(wbName) - 10)
Cells(rw, 4).Value = DoSubj
sDate = Split(DoTit, " ")
Cells(rw, 6).Value = DateSerial(sDate(2), sDate(1), sDate(0))
Cells(rw, 5).Value = DoAut
Cells(rw, 7).Value = Cells(rw, 6).Value - Cells(rw, 2).Value
rw = rw + 1
wbName = Dir
Wend
Cells(5, 5) = rw - 9
ObjWord.Quit
lrow2 = Range("B65000").End(xlUp).Row
Range("B9:H" & lrow2).Select
Selection.Sort Key1:=Range("B9"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Cells(1, 1).Select
If rw = 9 Then
MsgBox "Duong dan hoac tap tin khong ton tai ", , "Thong bao"
End If
Application.ScreenUpdating = True
End Sub





"Joel" wrote:

There are ways of speeding up the code. Post code if possible

Some tricks are to turn off screen up[dating and turn off events

Application.ScreenUpdating = False
Application.EnableEvents = False

If yu are deleting rows delete all the rows in one instruction rather than
one line at a time. I usually mark the rows I want to delete and then use
the mark to sort the rows I want to delete so the are all adjacent. There
are other tricks but without seeing the code I can't determine what is
slowing down your code.