Word Belgesinden Excel Tablosuna Veri Aktarımı

[CAFERCİFTCİ]

Değeri arkadaşlar,
Ekli örnekte de görüleceği üzere,word belgelerindeki kırmızı renkle yazılan yazılar değişken.Word belgesi tanzim edilip EVRAKLAR isimli bir klasöre kaydettiğimde bu kırmızı renkli bilgiler KAYIT CETVELİ adını verdiğim Excel tablosunda otomatikman sıralansınlar istiyorum.(En son yazılan word belgesi kayıt cetvelindeki ilk boş satıra sıralanmalı).
Muhterem üstadlar,yardımlarınızı istirham ediyor,iyi çalışmalar diliyorum...Saygılarımla.

 

[CAFERCİFTCİ]

Değerli Üstadlar,
Yardımlarınızı sabırsızlıkla bekliyorum.Lütfen....

 

[leumruk]

Değerli Üstadlar,
Yardımlarınızı sabırsızlıkla bekliyorum.Lütfen....

Merhaba,
Cafer Bey,
Word dosyasından parçalar halinde veri alıp excele aktarmak oldukça zor bir iş. Yaplabilir mi bilemiyorum.
Ayrıca word dosyasını klasöre attığınızda excel dosyasına bilgilerin aynı anda aktarılabilmesi de zor görünüyor. Excelin açık olması ve sürekli çalışan bir makro olması gerekiyor.
Sözü fazla uzatmadan, bu iş için farklı bir yol izlemeniz sonuç almanızı kolaylaştıracaktır kanaatindeyim.
Örneğin, word dosyalarını siz düzenliyorsanız, excel dosyanızda verdiğiniz tablodaki verileri siz elle girersiniz bir buton aracılığıyla bu verileri istediğiniz formatta worde aktarıp, aynı zamanda bu word dosyasını belirlediğiniz klasöre kaydedebilirsiniz. Yani tüm işlemleri excel üzerinden gerçekleştirebilirsiniz. ayrıca word dosyası düzenleyip elle klasöre atmanız gerekmez. Bütün bunlar otomatik gerçekleşir.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Word dosyalarını açarken makroları etkinleştirip açın.
Daha sonra değişiklikler yapıp dosyayı kapatın. Veriler excel dosyasına aktarılacaktır. Ve word dosyası kaydedilip kapatılacaktır.

Eksikleri varsa belirtirseniz düzeltmeye çalışırım.

Uygulanan kod;

Option Explicit
 
Sub WORD_TO_EXCEL()
    Dim EXCEL_UYGULAMASI As Object
    Dim EXCEL_DOSYASI As Object
    Dim DOSYA_YOLU As String
    Dim SATIR As Long
    Dim BUL As Object
    Dim VERİ As Integer
 
    Set EXCEL_UYGULAMASI = CreateObject("Excel.Application")
    DOSYA_YOLU = ActiveDocument.Path
    Set EXCEL_DOSYASI = EXCEL_UYGULAMASI.Workbooks.Open(DOSYA_YOLU & "\KAYIT CETVELİ.xls")
 
    If InStr(1, VBA.Trim(ActiveDocument.Paragraphs(1)), "Sayı:") > 0 Then
    Set BUL = EXCEL_DOSYASI.ActiveSheet.Range("B:B").Find(Val(EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Right(VBA.Trim(ActiveDocument.Paragraphs(1)), 5)))))
    If Not BUL Is Nothing Then
    SATIR = BUL.Row
    Else
    SATIR = EXCEL_DOSYASI.ActiveSheet.Range("A1").CurrentRegion.Rows.Count + 1
    End If
    End If
 
    If InStr(1, VBA.Trim(ActiveDocument.Paragraphs(1)), "Sayı:") > 0 Then
    EXCEL_DOSYASI.ActiveSheet.Range("A" & SATIR).Value = SATIR - 1
    VERİ = InStr(1, VBA.Trim(ActiveDocument.Paragraphs(1)), "/")
    If VERİ > 0 Then
    EXCEL_DOSYASI.ActiveSheet.Range("B" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Mid(VBA.Trim(ActiveDocument.Paragraphs(1)), VERİ + 1, 20)))
    Else
    EXCEL_DOSYASI.ActiveSheet.Range("B" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Right(VBA.Trim(ActiveDocument.Paragraphs(1)), 5)))
    End If
    End If
    If InStr(1, VBA.Trim(ActiveDocument.Paragraphs(2)), "Konu:") > 0 Then
    EXCEL_DOSYASI.ActiveSheet.Range("C" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Mid(VBA.Trim(ActiveDocument.Paragraphs(2)), 6, 20)))
    EXCEL_DOSYASI.ActiveSheet.Range("E" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Right(VBA.Trim(ActiveDocument.Paragraphs(2)), 12)))
    End If
    EXCEL_DOSYASI.ActiveSheet.Range("D" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(ActiveDocument.Paragraphs(5)))
    VERİ = InStr(1, VBA.Trim(ActiveDocument.Paragraphs(6)), "/")
    If VERİ > 0 Then
    EXCEL_DOSYASI.ActiveSheet.Range("G" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Mid(VBA.Trim(ActiveDocument.Paragraphs(6)), 1, VERİ - 1)))
    EXCEL_DOSYASI.ActiveSheet.Range("F" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Mid(VBA.Trim(ActiveDocument.Paragraphs(6)), VERİ + 1, 20)))
    Else
    EXCEL_DOSYASI.ActiveSheet.Range("F" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Mid(VBA.Trim(ActiveDocument.Paragraphs(6)), VERİ + 1, 20)))
    End If
    If InStr(1, VBA.Trim(ActiveDocument.Paragraphs(8)), "İlgi:") > 0 Then
    EXCEL_DOSYASI.ActiveSheet.Range("H" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Mid(VBA.Trim(ActiveDocument.Paragraphs(8)), 6, 11)))
    End If
    If InStr(1, VBA.Trim(ActiveDocument.Paragraphs(8)), "tarih ve") > 0 Then
    EXCEL_DOSYASI.ActiveSheet.Range("I" & SATIR).Value = EXCEL_DOSYASI.Application.Clean(VBA.Trim(VBA.Mid(VBA.Trim(ActiveDocument.Paragraphs(8)), 26, 4)))
    End If
    EXCEL_DOSYASI.ActiveSheet.Cells.EntireColumn.AutoFit
    EXCEL_DOSYASI.Save
    EXCEL_DOSYASI.Close
    Set EXCEL_DOSYASI = Nothing
    Set EXCEL_UYGULAMASI = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
 
    ThisDocument.Save
    Application.Quit
End Sub

 

[CAFERCİFTCİ]

Korhan Bey,
İlginize teşekkür ederim.Örnekteki word belgelerini açarken makroları etkinleştirdim,Değişiklikler yapıp CTRL+F12 ye de bastım.Ancak kayıt cetvelinde herhangi bir değişiklik olmadı.CTRL+F12 ye bastığımda çıkan tablodan yanlış yer mi seçerek kaydediyorum acaba?Çünkü örnek dosya belgelerimin içerisinde.CTRL+f12 ye bastıktan sonraki aşamayı da istirham etsem sizi çok yormuş olurmuyum?İyi geceler...

 

[CAFERCİFTCİ]

Günaydınlar Korhan Bey,
Online olduğunuzu görünce gece sorduğum soruyu yinelemek istedim.CTRL+12 den sonraki aşama.Kayıt aşaması.Benim word dosyalarım ve Kayıt Cetveli isimli excel dosyam masaüstünde.Sonuç alabilmek için bu aşamada neler yapmalıyım?Lütfen...

 

[Korhan Ayhan]

Selamlar,

Sn. CAFERCİFTCİ,

Eklemiş olduğum dosyaların hepsi aynı klasörde olmalıdır. Bu şekilde ise sorun çıkarmadan çalışacaktır.

Ayrıca Word dosyalarını açtığınızda ALT+F11 tuşlarına basın kod editörü açılacaktır. Her dosya içinde sol üst bölümde "Modules" klasörü içinde iki adet modül olması gerekiyor. Bunada dikkat edin.

Makronun sağlıklı çalışması için tüm word belgelerindeki ilk 8 satırın aynı yapıda olması gerekiyor.

Ayrıca CTRL+F12 tuşuna bastığınızda "İşleminiz tamamlanmıştır." mesajını almanız ve word belgesinin otomatik kapanması gerekiyor.

 

[CAFERCİFTCİ]

Sadece Son Aşama

Korhan Bey,
Word Dosyaları ve Kayıt Cetveli isimli excel dosyası(Örneğinizdekiler) masa üzerinde ÖRNEK isimli tek bir klasörün içerisinde.Modül konusunda da sorun yok.Zaten word belgelerinin içerikleri şimdilik boş olduğu için ilk 8 satırla ilgili sorun da yok.Fakat,CTRL+F12 ye bastığımda bahsettiğiniz iletiyi alamıyorum,dosya da otomatik kapanmıyor.Onun yerine nereye kaydedeceğimizi gösteren tablo çıkıyor.Sorun Burada.

 

[CAFERCİFTCİ]

Somut Bir örnek Mümkün mü?

Merhaba,
Cafer Bey,
Word dosyasından parçalar halinde veri alıp excele aktarmak oldukça zor bir iş. Yaplabilir mi bilemiyorum.
Ayrıca word dosyasını klasöre attığınızda excel dosyasına bilgilerin aynı anda aktarılabilmesi de zor görünüyor. Excelin açık olması ve sürekli çalışan bir makro olması gerekiyor.
Sözü fazla uzatmadan, bu iş için farklı bir yol izlemeniz sonuç almanızı kolaylaştıracaktır kanaatindeyim.
Örneğin, word dosyalarını siz düzenliyorsanız, excel dosyanızda verdiğiniz tablodaki verileri siz elle girersiniz bir buton aracılığıyla bu verileri istediğiniz formatta worde aktarıp, aynı zamanda bu word dosyasını belirlediğiniz klasöre kaydedebilirsiniz. Yani tüm işlemleri excel üzerinden gerçekleştirebilirsiniz. ayrıca word dosyası düzenleyip elle klasöre atmanız gerekmez. Bütün bunlar otomatik gerçekleşir.

Mustafa Hocam,
Öncelikle ilginize teşekkür ederim.Eğer lütfeder de önerinizi vermiş olduğum örnekler üzerinde somutlaştırabilirseniz sanırım anlayabilmem daha kolay olur.İyi çalışmalar...

 

[leumruk]

Merhaba,

Dosya yolunda belirttiğim kırmızı alanı kendi bilgisayarınıza göre düzenlemelisiniz. Rar dosyasındaki klasörü bilgisayarınıza çıkarmanız gerekli.

Sub Aktar()
For x = 1 To 8
If Cells(65536, x).End(3).Row <> Cells(65536, x + 1).End(3).Row Then
MsgBox "Girilmemiş veri var. Lütfen tablonuzu kontrol ediniz."
Exit Sub: End If: Next

Sat = [a65536].End(3).Row
[Sayfa2!b1] = "D.15.Y.20/" & Cells(Sat, "b")
[Sayfa2!b2] = Cells(Sat, "c")
[Sayfa2!d5] = Cells(Sat, "d")
[Sayfa2!j2] = Cells(Sat, "e")
[Sayfa2!e6] = Cells(Sat, "g") & "/" & Cells(Sat, "f")
[Sayfa2!b8] = Cells(Sat, "h") & " tarih ve " & Cells(Sat, "ı") & " sayılı yazınız."

[Sayfa2!a1:j8].Copy
Set WD = CreateObject("Word.Application")
WD.Visible = True
Set MyDoc = WD.Documents.Add(DocumentType:=wdNewBlankDocument)
WD.Selection.WholeStory
WD.Selection.PasteSpecial DataType:=2
Application.CutCopyMode = False
Set WDApp = GetObject(, "Word.Application")
Set WDDoc = WDApp.ActiveDocument

Range(Cells(Sat, "a"), Cells(Sat, "ı")).Borders.LineStyle = xlContinuous

DosyaAdi = Cells(Sat, "a")
WDDoc.SaveAs "C:\[COLOR="Red"]Users\mustafa\Desktop[/COLOR]\CAFER ÇİFTÇİ\" & DosyaAdi & ".Doc"

End Sub

 

[CAFERCİFTCİ]

Yol Hatası

Mustafa Hocam,emeğinize sağlık,gayet güzel oldu.Yalnız benim dosya yolum şu şekilde:C:\Documents and Settings\caferciftci\Desktop bunu sizin yazdığınız koda uyarladım.Belgeyi oluşturuyor fakat hata mesajı da veriyor.Birde,bu excel tablosunun ilk satırından başlamak istiyorum.Sonra sırayla ekleme devam etmeli.Bunun için ne yapmam gerekir acaba?

 

[leumruk]

Cafer Bey,
Kodlar daima son satırdaki verilere göre dosya oluşturur. Yani ilk satıra göre dosya oluşturmak için ilk satırdan sonraki satırların boş olması gerekli.
Nasıl bir hata mesajı verdi?

 

[CAFERCİFTCİ]

Hata

Run-time error "5152"
Mustafa hocam,bu hatayı veriyor,çözüm yolu olarak da
1-Yolun doğru yazıldığından emin olun
2-Dosyalar ve klasörler listesinden bir klasör seçin diyor.
Bu arada ben 4 word belgesinden üçünü sildim.Tek satır kaldı ve işlemi de yaptı.
Mustafa Hocam,birde tanzim edilen bu belgeleri örneğin RAPORLAR adını verdiğim bir klasöre nasıl kaydedebilirim?

 

[leumruk]

Muhtemelen dosya yolunda bir sorun var. Eklemiş olduğum klasöre sağ tıklayıp gördüğünüz dosya yolunu buraya yazar mısınız? Karakterler birebir olsun?

 

[CAFERCİFTCİ]

C:\Documents and Settings\caferciftci\Desktop
Mustafa Hocam,sanırım bunu soruyorsunuz.Bir de klasöre kayıt olayı var.İzninizle çıkmak durumundayım çünkü mesai bitiyor.Evden yeniden giriş yapıp mesajınızı uygulamaya çalışacağım.Şimdilik iyi akşamlar hocam.

 

[leumruk]

İlgili satırı aşağıdakiyle değiştirin:

WDDoc.SaveAs "C:\Documents and Settings\caferciftci\Desktop\CAFER ÇİFTÇİ\" & DosyaAdi & ".Doc"

 

[CAFERCİFTCİ]

Aynı hata

İyi geceler mustafa hocam.yazdığınız yol zaten benim sizin örneğinizdekinin yerine benim yazdığım yol.Yine de kopyalayıp yapıştırdım.Aynı hata mesajını veriyor.Tekrar iyi geceler...

 

[leumruk]

İyi geceler,
Belirttiğiniz hata dosya yoluyla ilgili. Mutlaka gözden kaçan bir şeyler vardır. Emin olmak için kendi dosya yolumu yanlış yazdım ve sizin bana belirttiğiniz hatanın aynısını verdi.
Bir de şu dosya yolunu deneyin. Eğer bunu kullanırsanız. Word dosyaları ile excel dosyasının aynı klasörde olması gerekir.

Eski yolu silin ve bunu yazın:

WDDoc.SaveAs ThisWorkbook.Path & "\" & DosyaAdi & ".Doc"

 

[Korhan Ayhan]

Selamlar,

Sn. CAFERCİFTCİ,

Bende üstteki mesajımdaki dosyaları revize ettim. İncelermisiniz.

Word dosyalarını açın değişiklik yapıp dosyayı kapatın. Kapanırken veriler excel dosyasına otomatik olarak aktarılacaktır.

 

[tahsinanarat]

Sn. CAFERCİFTCİ; Ben şunu anlamak istiyorum, bilgiler excel'den word belgesine mi? yoksa word belgesindeki bilgiler excel'e mi aktarılmak isteniyor, anlayamadım. 1.mesajınızda sorduğunuz soruya göre Korhan hocamın verdiği cevabın uygun olduğunu düşündüm, ama yaptığım denemelerden bir sonuç alamadım.