Word dosyalarındaki sayıların excel dosyasına aktarımı

[VeliDemir]

Merhaba,

Bir klasörün içindeki her word dosyasında sonu "kaydı" kelimesiyle biten sayıları bir excel dosyasındaki alt alta gelen hücrelere aktarmak istiyorum. Bu nedenle, bunu sağlayabilecek bir makro programını biliyorsanız sizden söz konusu programı rica ediyorum.

Yukarıda bahsettiğim konuyu daha iyi anlatan somut bir örneği ekte sunmaktayım.

İyi günler.

 

[hamitcan]

C dizini altında word isimli bir klasör oluşturun. Bir Excel dosyası içinde bir Module kodu ekleyip çalıştırın.

Sub icinde_kaydi_kelimesi_gecenler()
'********************hamitcan 15/01/2010*******************
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.WorkSheet
    Dim ds, dc, f, dosya
    Dim yol As String, tString As String
    Dim j As Integer, i As Integer
    
    yol = "C:\word\"
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set f = ds.GetFolder(yol)
    Set dc = f.Files

    Application.ScreenUpdating = False
    For Each dosya In dc
    If ds.GetExtensionName(dosya) = "doc" Then
    Documents.Open yol & dosya.Name
            With ActiveDocument
                For i = 1 To .Paragraphs.Count
                    Set tRange = .Range(Start:=.Paragraphs(i).Range.Start, _
                                  End:=.Paragraphs(i).Range.End)
                                  tString = tRange.Text
                    If InStr(1, tString, "kaydı") > 1 Then
                          j = j + 1
                          xlSheet.Cells(j, 1) = Left(tString, InStr(1, tString, "kaydı") - 1)
                    End If
                Next
                .Close
            End With
            xlApp.Visible = True
           End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[VeliDemir]

Hamitcan bey, size bu yardımınızdan ötürü çok teşekkür ederim.

Ancak, söz konusu makro programını çalıştırırken, makro programındaki "Documents.Open yol & dosya.Name" ifadesi ile ".Paragraphs.Count" ifadesinde "Run-time error '424' : Object required" şeklinde bir hata mesajıyla karşılaştım. Bu konuda bana yardımcı olabilirseniz çok sevinirim.

İyi günler.

 

[hamitcan]

2 nolu mesajımda belirttiğim gibi dosyalarınızı "C:\word" isimli bir klasöre eklediniz mi ?

 

[kayserciyes]

bunuı bende uygulayamadım

C\word ün içinde veri alınacak word dosyaları mı olacak yoksa veriyi alacak olan excel mi olacak veya hepsi mi

üçünüde denedim olmadı hat verdi

 

[hamitcan]

Evet haklısınız, ben kodu word içinde çalıştırdığım için doğru çalışmış. Eğer kodu Word içinde bir module yerleştirip çalıştırırsanız sorun olmayacaktır. Excelde çalışacak bir kod yapmaya çalışacağım.

 

[hamitcan]

Bir de aşağıdaki şekilde deneyin.

Sub icinde_kaydi_kelimesi_gecenler()
'********************hamitcan 15/01/2010*******************
    Dim xlApp As Excel.Application
    Dim oWord As Object
    Dim xlAppW As Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim ds, dc, f, dosya
    Dim yol As String, tString As String
    Dim j As Integer, i As Integer
    
    yol = "C:\word\"
    Set xlApp = CreateObject("Excel.Application")
    Set oWord = CreateObject("Word.application")
    Set ds = CreateObject("Scripting.FileSystemObject")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    Set f = ds.GetFolder(yol)
    Set dc = f.Files

    Application.ScreenUpdating = False
    For Each dosya In dc
    If ds.GetExtensionName(dosya) = "doc" Then
     oWord.Documents.Open yol & dosya.Name
            With oWord.ActiveDocument
                For i = 1 To .Paragraphs.Count
                    Set tRange = .Range(Start:=.Paragraphs(i).Range.Start, _
                                  End:=.Paragraphs(i).Range.End)
                                  tString = tRange.Text
                    If InStr(1, tString, "kaydı") > 1 Then
                          j = j + 1
                          xlSheet.Cells(j, 1) = Left(tString, InStr(1, tString, "kaydı") - 1)
                    End If
                Next
                .Close
            End With
            xlApp.Visible = True
           End If
    Next
    Application.ScreenUpdating = True
End Sub