Kapalı word dosyasından excele tablo almak

[tamer42]

Merhabalar;

Belirlenen folder ("C:\My Folder") içerisinde word dosyası olarak hazırlanmış haftalık formlar var.

Ekte bir örneği olduğu şekilde Form Adları:
Form_w01, Form_w02, Form_w03 , ......., Form_w51, Form_w52


Folder içindeki tüm word dosyalarının;
Ekteki örnekte sarı ile boyalı alanları alt alta bir excel dosyasına aktarmak istiyorum.


Yardımlarınız için şimdiden teşekkürler...

İyi Çalışmalar dileklerimle..

 

[Mahmut Kök]

Word belgelerinizin tamamı aynı şekilde mi? Üstte Başlık bilgilerini içeren tablo; altta da son 2 satırı aktarılacak olan 3 satırlık başka bir tablo... Yoksa, bilgi aktarılacak tablodaki satır sayıları değişken mi?

 

[tamer42]

Merhabalar,

Word belgelerinin formatı aynı şekilde,

Üstte Başlık bilgilerini içeren tablo;

Altta sabit bir başlık - aktarılacak tablodaki satır sayıları ise değişken dir. Burada 2 satır var, başka dosyalarda bu satır sayısı 20 ye kadar çıkabilmektedir.


İyi Haftasonları dilerim.

 

[Mahmut Kök]

FORM_w05.doc adlı belgenizi, C:\Form_w05.doc olacak şekilde yerleştirmeniz ve Referanslardan Microsoft Word ? referansını eklemeniz gerekmektedir. Excel belgenizde bir modul oluşturarak, aşağıdaki kodları, oraya olduğu gibi yapıştırınız ve deneme adlı makroyu çalıştırınız. Eğer, bu kodlar işinizi görecek gibi ise, geliştirilebilir.

Dim doc As Word.Application
Dim belge As Word.Document
Sub deneme()
Set doc = CreateObject("word.Application")
Set belge = doc.Documents.Open("c:\FORM_w05.doc")
satır = belge.Tables(2).Rows.Count
For a = 2 To satır
sate = Range("a65536").End(3).Row + 1
nesne1 = belge.Tables(2).Rows(a).Cells(1)
nesne2 = belge.Tables(2).Rows(a).Cells(2)
nesne3 = belge.Tables(2).Rows(a).Cells(3)
Cells(sate, "a") = nesne1
Cells(sate, "b") = nesne2
Cells(sate, "c") = nesne3
Next
belge.Close
doc.Quit
enterle
MsgBox "AKTARMA İŞLEMİ TAMAMLANDI."
End Sub
Sub enterle()
Dim parça(50)
p = 0
             For ss = 2 To [c65536].End(3).Row
                    z = 1
                    For a = 1 To Len(Cells(ss, 3))
 
                    If Mid(Cells(ss, 3), a, 1) = Chr(13) Then
                    değer = Mid(Cells(ss, 3), a, 1)
                    p = p + 1
                        If z > 1 Then
                    parça(p) = Mid(Cells(ss, 3), z + 1, a - (z + 1))
                    z = a
                    Else
                    parça(p) = Mid(Cells(ss, 3), z, a - (z))
                    z = a
                    End If
                    End If
                    Next
                    If p = 0 Then GoTo 3
                    Cells(ss, 3) = Empty
                    For pp = 1 To p
                    Cells(ss, 3) = Cells(ss, 3) & parça(pp) & Chr(10)
                    Next
                    For pp = 1 To p
                    parça(pp) = Empty
                    Next
                    p = 0
3
              Next
 
End Sub

 

[tamer42]

İlginize Teşekkürler...

Deneyip, sonuçları hk. size bilgi vereceğim.

İyi Çalışmalar.

 

[tamer42]

Kodlar gayet güzel çalışıyor,

Burada ("C:\My Folder") bulunan diğer tüm word dosyaların içeriğini tek seferde almak için nasıl bir geliştirme yapılabilir.

Tekrar teşekkürler...