Word belgesinden Excele Veri Alabilmek

[yesimgurol]

Merhabalar;

Büyük ölçüde faydalandığım bu forumda her zamanki gibi bana büyük büyük faydası dokunacak bir sorunumu paylaşmak istedim.

Word belgesinde hazırladığım raporlarımdan (Ekte "RAPOR ÖRNEĞİ"), Excelde hazırladığım listeye (Ekte "LİSTE") bir kaç veri alabilmek mümkün müdür?

Ekte ki örnek dosya üzerinde anlatmaya çalıştım.Siz saygı değer hocalarımdan fikirlerinizi ve yardımlarınızı bekliyorum.Şimdiden konumu okuyup en azından zaman ayırdığınız için teşekkür ederim...

 

[yesimgurol]

Forumda araştırma yaptım.Word ten Excel e aktarılan veriler olduğunu gördüğü isem de inanın kodlardan bilgi sahibi olmadığımdan anlayamadım.

Konu hakkında yardımlarınızı bekliyorum:-(

 

[yesimgurol]

Sayın leumruk; kusura bakmayın , yanlış anlamaz iseniz, forum içerisinde Word den Excel e veri aktarımı ile ilgili örneklerinizi gördüm..
Kodlar hakkında bilgi sahibi olmadığım dan kendim için uyarlayamadım..
Yardımcı olabilir misiniz?

 

[leumruk]

Merhaba,
Şu an pek vaktim yok, ama uygun bir zaman bakacağım. Siz bu sırada bir kaç ayrıntıyı belirtirseniz üzerinde düşünürken doğru hareket etmiş oluruz.
1- Raporunuz bir tane mi? Birden fazla mı?
2- Eğer raporlarınız birden fazla ise word dosyanızdaki tablolar aynı yapı ve düzende mi?

 

[yesimgurol]

İlginize ve dikkatinize çok teşekkür ederim.

 

[yesimgurol]

Bir klasör içinde yaklaşık 150-200 adet aynı formatta Word de hazırlanmış raporum var.
Ekte mevcut olan RAPOR ÖRNEĞİ dosyası gibi.
Bu raporlar içinden excele ilgili verileri anlattığım şekilde almamız mümkün mü peki? Yada açıklamam yeterli mi sizin için ?

 

[leumruk]

Bu raporlar içinden excele ilgili verileri anlattığım şekilde almamız mümkün mü peki? Yada açıklamam yeterli mi sizin için ?

Evet, almamız mümkün. Daha önce buna benzer bir kaç örnek yapmıştım. 1-2 gün içinde fırsat bulursam konuya bakacağım.

 

[leumruk]

Merhaba,
Örnek klasörü rar klasöründen çıkarıp deneyin.

Sub wd_xl()
Sayfa1.Range("A3:M1000").ClearContents
'Application.ScreenUpdating = False
Set wd = CreateObject("word.Application")
wd.Visible = True
dosya = Dir(ThisWorkbook.Path & "\*.doc*")
Sat = 0
Wst = Array("Kurşun", "Çinko", "Nikel", "Alimunyum", "Civa", "Bakır", "Tungsten", "Kalay", "Provakasyon")
WSTknt = "Kurşun-Çinko-Nikel-Alimunyum-Civa-Bakır-Tungsten-Kalay"
Stn = Array("", 2, 9, 11, 3, 4, 5, 10, 8)
krtr = Array("", 5, 2.5, 25, 60, 5, 0.12, 1.5, 15)
Do While dosya <> ""
On Error GoTo son
wd.Application.Documents.Open ThisWorkbook.Path & "\" & dosya
Set tbl = wd.ActiveDocument.Tables(1)
Sat = Cells(Rows.Count, 1).End(3).Row + 1
For x = 5 To tbl.Rows.Count - 1
deg = Trim(tbl.cell(x, 1).Range): deg = Left(deg, Len(deg) - 2)
If Len(deg) > 0 Then
    If "Provakasyon" = Left(deg, 11) Then dmsa = LTrim(Split(tbl.cell(x, 3).Range, ":")(1))
        If InStr(1, WSTknt, deg, vbTextCompare) > 0 Then
            sira = WorksheetFunction.Match(deg, Wst, 0)
            veri = Trim(Left(tbl.cell(x, 2).Range, Len(tbl.cell(x, 2).Range) - 2))
                If Len(veri) > 0 And IsNumeric(Replace(veri, ".", ",")) = True Then
                    If Round(Replace(veri, ".", ","), 2) > krtr(sira) Then
                        Cells(Sat, Stn(sira)) = veri
                    End If
                End If
        End If
End If
Next
    If WorksheetFunction.CountA(Range("b" & Sat & ":k" & Sat)) > 0 Then
        Cells(Sat, 1) = Sat - 2
        Cells(Sat, 13) = dosya
            Cells(Sat, "f") = Split(dmsa, " ")(0)
            yas = Split(tbl.cell(2, 1).Range.Paragraphs(4), ":")(1)
        Cells(Sat, "g") = Left(yas, Len(yas) - 1)
    End If
son:
If Err.Number <> 0 Then Cells(Sat, 12) = "HATA"
wd.ActiveDocument.Close False
dosya = Dir
Loop
If Sat > 0 Then
wd.Application.Quit
End If
MsgBox "İşlem tamam", vbInformation, "l e u m r u k"
End Sub

 

[assenucler]

Sayın leumruk;

Merhabalar.. Emek ve paylaşımınız için teşekkürler.

Sevgi ve saygılar.

 

[yesimgurol]

Sayın Leumruk; teşekkür ederim ilginize..Gayet güzel olmuş emeğinize sağlık gerçekten.

Yalnız veri alma konusunda bir kaç kısıtlama getirme imkanımız varmıdır? Ben ekteki LİSTE sayfasında olması muhtemel kısıtlamalar hakkında açıklama yapmaya çalıştım.Bu kısıtlamaları yapma ihtimalimiz varsa çok mutlu olurum.

Tekrar çok teşekkür ederim.Bu forumu çoook seviyorum...

Bu arada, Sayın Murat OSMA beye de çok selamlar.Okuma fırsatı oldu ise...

 

[yesimgurol]

Dosya eklemeyi unutmuşum 10 nolu mesaj da belirttiğim dosyayı eklemiş oldum.LİSTE adlı sayfada kısıtlamalar hakkında açıklama yapmaya çalıştım.İlginize tekrar çok teşekkür ederim...İyi çalışmalar...

 

[Murat OSMA]

Merhaba Yeşim Hanım,

Kulaklarımı çınlatmışsınız ama yoğunluktan farkedemedim.
Çıkmadan girip bir bakayım derken tesadüfen konuyu ve mesajınızı gördüm.
Word ile ilgili konularla pek ilgilenmem, zirâ en sevmediğim office programıdır...


Çok teşekkür ediyorum, iyi akşamlar...

 

[yesimgurol]

Olsun sadece Merhaba demek istemiştim..Yoğunsunuzdur eminim,iyi çalışmalar..Sağolsun Sayın leumruk bey in yardımı büyük ölçüde oldu bana üzerinde bir kaç isteğim oldu onlarıda halledebilirsem çok daha güzel olacak inşaallah

 

[Murat OSMA]

Anladım, size de iyi çalışmalar.

Hoşça kalın !!!

 

[yesimgurol]

Teşekkür ederim.Sizede..

 

[leumruk]

Merhaba,
Bir kaç defa deneyip, kontrol ettikten sonra kullanın. Pek deneme şansım olmadı.

Sub Word_den_Excele()
Application.ScreenUpdating = False
Set wd = CreateObject("word.Application")
wd.Visible = False
dosya = Dir(ThisWorkbook.Path & "\*.doc*")
Sat = 0
Do While dosya <> ""
On Error GoTo son
wd.Application.Documents.Open ThisWorkbook.Path & "\" & dosya
    Set tbl = wd.ActiveDocument.Tables(1)
    Sat = Cells(Rows.Count, 1).End(3).Row + 1
    bkr = tbl.Cell(16, 2).Range: bkr = Left(bkr, Len(bkr) - 1)
        Cells(Sat, "e") = IIf(Int(bkr) > 12, bkr, "")
    aym = tbl.Cell(29, 2).Range: aym = Left(aym, Len(aym) - 1)
        Cells(Sat, "c") = IIf(Replace(aym, ".", ",") > 60, aym, "")
    civa = tbl.Cell(35, 2).Range: civa = Left(civa, Len(civa) - 1)
        Cells(Sat, "d") = IIf(Replace(civa, ".", ",") > 5, civa, "")
    krsn = tbl.Cell(37, 2).Range: krsn = Left(krsn, Len(krsn) - 1)
        Cells(Sat, "b") = IIf(Replace(krsn, ".", ",") > 5, krsn, "")
    If WorksheetFunction.CountA(Range("b" & Sat & ":e" & Sat)) > 0 Then
        Cells(Sat, 1) = Sat - 2
            dmsa = LTrim(Split(tbl.Cell(25, 3).Range, ":")(1))
            Cells(Sat, "f") = Split(dmsa, " ")(0)
            yas = Split(tbl.Cell(2, 1).Range.Paragraphs(4), ":")(1)
        Cells(Sat, "g") = Left(yas, Len(yas) - 1)
    End If
son:
If Err.Number <> 0 Then
Cells(Sat, 1) = Sat - 2
Cells(Sat, 2) = dosya
Range("c" & Sat & ":g" & Sat) = "HATA"
End If
wd.ActiveDocument.Close False
dosya = Dir
Loop
If Sat > 0 Then
wd.Application.Quit
End If
MsgBox "İşlem tamam", vbInformation, "l e u m r u k"
End Sub

 

[yesimgurol]

Sayın leumruk,teşekkür ederim.Şimdi bakabildim.Ricada bulunacağım lakin şunu belirtmek isterim yoğunsunuzdur eminim..O kadar yoğunluğunuz da elbette vakit ayıramayacak sınızdır..

Lakin ben denedim son düzenlemenizden sonra B,C,D sutunlarına gelen verilerde kısıtlamalar sanırım stabil olmuyor.
Denemelerimde bazılarında kısıtlamalarımız gecerli oluyor.Bazılarında yine belirlediğimiz değerden küçük olanları da aktarıyor.

Birkaç düzenlemeye ihtiyacı olacak saanırım:-(

İlginize ve emeğinize tekrar teşekkür ederim , iyi çalışmalar...

 

[yesimgurol]

Kısıtlamalar tam çalışmıyor sanırım:-(

 

[leumruk]

Merhaba,
16 nolu mesajı güncelledim. Örneği yeniden deneyebilirsiniz.

 

[yesimgurol]

Sayın leumruk;
Emeğinize sağlık.Güncellediğiniz dosya tam istediğim gibi olmuş.
Kullanacağım klasör içine aldım LİSTE sayfasını çalıştırdım.Aldığım "Error" mesajının ve kod içerindeki "sarı renkli" satırın ekran görüntüsünü ekledim.Sanırım Word belgesinde sorun oldu.
Bu durumda nasıl bir yol izlemeliyim ?

Mesela;200 adet rapor var klasörde, atıyorum 50 tane taradı 51.gelince sorun buldu ve bu error mesajını verdi diyelim.Bu hatalı raporu yoksay deyip "taramaya devam et" deme şansımız var mıdır?

Çünkü anladığım kadarı ile tarama esnasında uygun olmayan rapor örneği bulduğunda taramayı kesip error mesajını veriyor.
Bu tarama esnasında uygun olmayan rapor çıktığında bunları otomatik yoksaymasını ,
taramaya devam etmesini ,sorun olan raporları da belirtme ihtimali olmasını istesem:-(

Şunu belirtmek isterim ki,bu haliyle yapmış olduğunuz dosya benim düşündüğümün çoook ötesinde harika birşey emeğinize sağlık...
Lakin yukarda belirtmeye çalıştım aksaklıkların giderilmesi mümkünse , yapmak için zamanınız var ise mutlu olurum.

Tekrar çok teşekkür eder,iyi çalışmalar dilerim.